| 1 | | | | | package CGI; |
| 2 | 1 | 94µs | | | %SUBS = ( |
| 3 | | | | | |
| 4 | | | | | 'URL_ENCODED'=> <<'END_OF_FUNC', |
| 5 | | | | | sub URL_ENCODED { 'application/x-www-form-urlencoded'; } |
| 6 | | | | | END_OF_FUNC |
| 7 | | | | | |
| 8 | | | | | 'MULTIPART' => <<'END_OF_FUNC', |
| 9 | | | | | sub MULTIPART { 'multipart/form-data'; } |
| 10 | | | | | END_OF_FUNC |
| 11 | | | | | |
| 12 | | | | | 'SERVER_PUSH' => <<'END_OF_FUNC', |
| 13 | | | | | sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; } |
| 14 | | | | | END_OF_FUNC |
| 15 | | | | | |
| 16 | | | | | 'new_MultipartBuffer' => <<'END_OF_FUNC', |
| 17 | | | | | # Create a new multipart buffer |
| 18 | | | | | sub new_MultipartBuffer { |
| 19 | | | | | my($self,$boundary,$length) = @_; |
| 20 | | | | | return MultipartBuffer->new($self,$boundary,$length); |
| 21 | | | | | } |
| 22 | | | | | END_OF_FUNC |
| 23 | | | | | |
| 24 | | | | | 'read_from_client' => <<'END_OF_FUNC', |
| 25 | | | | | # Read data from a file handle |
| 26 | | | | | sub read_from_client { |
| 27 | | | | | my($self, $buff, $len, $offset) = @_; |
| 28 | | | | | local $^W=0; # prevent a warning |
| 29 | | | | | return $MOD_PERL |
| 30 | | | | | ? $self->r->read($$buff, $len, $offset) |
| 31 | | | | | : read(\*STDIN, $$buff, $len, $offset); |
| 32 | | | | | } |
| 33 | | | | | END_OF_FUNC |
| 34 | | | | | |
| 35 | | | | | 'delete' => <<'END_OF_FUNC', |
| 36 | | | | | #### Method: delete |
| 37 | | | | | # Deletes the named parameter entirely. |
| 38 | | | | | #### |
| 39 | | | | | sub delete { |
| 40 | | | | | my($self,@p) = self_or_default(@_); |
| 41 | | | | | my(@names) = rearrange([NAME],@p); |
| 42 | | | | | my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names; |
| 43 | | | | | my %to_delete; |
| 44 | | | | | for my $name (@to_delete) |
| 45 | | | | | { |
| 46 | | | | | CORE::delete $self->{param}{$name}; |
| 47 | | | | | CORE::delete $self->{'.fieldnames'}->{$name}; |
| 48 | | | | | $to_delete{$name}++; |
| 49 | | | | | } |
| 50 | | | | | @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param(); |
| 51 | | | | | return; |
| 52 | | | | | } |
| 53 | | | | | END_OF_FUNC |
| 54 | | | | | |
| 55 | | | | | #### Method: import_names |
| 56 | | | | | # Import all parameters into the given namespace. |
| 57 | | | | | # Assumes namespace 'Q' if not specified |
| 58 | | | | | #### |
| 59 | | | | | 'import_names' => <<'END_OF_FUNC', |
| 60 | | | | | sub import_names { |
| 61 | | | | | my($self,$namespace,$delete) = self_or_default(@_); |
| 62 | | | | | $namespace = 'Q' unless defined($namespace); |
| 63 | | | | | die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::; |
| 64 | | | | | if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) { |
| 65 | | | | | # can anyone find an easier way to do this? |
| 66 | | | | | for (keys %{"${namespace}::"}) { |
| 67 | | | | | local *symbol = "${namespace}::${_}"; |
| 68 | | | | | undef $symbol; |
| 69 | | | | | undef @symbol; |
| 70 | | | | | undef %symbol; |
| 71 | | | | | } |
| 72 | | | | | } |
| 73 | | | | | my($param,@value,$var); |
| 74 | | | | | for $param ($self->param) { |
| 75 | | | | | # protect against silly names |
| 76 | | | | | ($var = $param)=~tr/a-zA-Z0-9_/_/c; |
| 77 | | | | | $var =~ s/^(?=\d)/_/; |
| 78 | | | | | local *symbol = "${namespace}::$var"; |
| 79 | | | | | @value = $self->param($param); |
| 80 | | | | | @symbol = @value; |
| 81 | | | | | $symbol = $value[0]; |
| 82 | | | | | } |
| 83 | | | | | } |
| 84 | | | | | END_OF_FUNC |
| 85 | | | | | |
| 86 | | | | | #### Method: keywords |
| 87 | | | | | # Keywords acts a bit differently. Calling it in a list context |
| 88 | | | | | # returns the list of keywords. |
| 89 | | | | | # Calling it in a scalar context gives you the size of the list. |
| 90 | | | | | #### |
| 91 | | | | | 'keywords' => <<'END_OF_FUNC', |
| 92 | | | | | sub keywords { |
| 93 | | | | | my($self,@values) = self_or_default(@_); |
| 94 | | | | | # If values is provided, then we set it. |
| 95 | | | | | $self->{param}{'keywords'}=[@values] if @values; |
| 96 | | | | | my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : (); |
| 97 | | | | | @result; |
| 98 | | | | | } |
| 99 | | | | | END_OF_FUNC |
| 100 | | | | | |
| 101 | | | | | # These are some tie() interfaces for compatibility |
| 102 | | | | | # with Steve Brenner's cgi-lib.pl routines |
| 103 | | | | | 'Vars' => <<'END_OF_FUNC', |
| 104 | | | | | sub Vars { |
| 105 | | | | | my $q = shift; |
| 106 | | | | | my %in; |
| 107 | | | | | tie(%in,CGI,$q); |
| 108 | | | | | return %in if wantarray; |
| 109 | | | | | return \%in; |
| 110 | | | | | } |
| 111 | | | | | END_OF_FUNC |
| 112 | | | | | |
| 113 | | | | | # These are some tie() interfaces for compatibility |
| 114 | | | | | # with Steve Brenner's cgi-lib.pl routines |
| 115 | | | | | 'ReadParse' => <<'END_OF_FUNC', |
| 116 | | | | | sub ReadParse { |
| 117 | | | | | local(*in); |
| 118 | | | | | if (@_) { |
| 119 | | | | | *in = $_[0]; |
| 120 | | | | | } else { |
| 121 | | | | | my $pkg = caller(); |
| 122 | | | | | *in=*{"${pkg}::in"}; |
| 123 | | | | | } |
| 124 | | | | | tie(%in,CGI); |
| 125 | | | | | return scalar(keys %in); |
| 126 | | | | | } |
| 127 | | | | | END_OF_FUNC |
| 128 | | | | | |
| 129 | | | | | 'PrintHeader' => <<'END_OF_FUNC', |
| 130 | | | | | sub PrintHeader { |
| 131 | | | | | my($self) = self_or_default(@_); |
| 132 | | | | | return $self->header(); |
| 133 | | | | | } |
| 134 | | | | | END_OF_FUNC |
| 135 | | | | | |
| 136 | | | | | 'HtmlTop' => <<'END_OF_FUNC', |
| 137 | | | | | sub HtmlTop { |
| 138 | | | | | my($self,@p) = self_or_default(@_); |
| 139 | | | | | return $self->start_html(@p); |
| 140 | | | | | } |
| 141 | | | | | END_OF_FUNC |
| 142 | | | | | |
| 143 | | | | | 'HtmlBot' => <<'END_OF_FUNC', |
| 144 | | | | | sub HtmlBot { |
| 145 | | | | | my($self,@p) = self_or_default(@_); |
| 146 | | | | | return $self->end_html(@p); |
| 147 | | | | | } |
| 148 | | | | | END_OF_FUNC |
| 149 | | | | | |
| 150 | | | | | 'SplitParam' => <<'END_OF_FUNC', |
| 151 | | | | | sub SplitParam { |
| 152 | | | | | my ($param) = @_; |
| 153 | | | | | my (@params) = split ("\0", $param); |
| 154 | | | | | return (wantarray ? @params : $params[0]); |
| 155 | | | | | } |
| 156 | | | | | END_OF_FUNC |
| 157 | | | | | |
| 158 | | | | | 'MethGet' => <<'END_OF_FUNC', |
| 159 | | | | | sub MethGet { |
| 160 | | | | | return request_method() eq 'GET'; |
| 161 | | | | | } |
| 162 | | | | | END_OF_FUNC |
| 163 | | | | | |
| 164 | | | | | 'MethPost' => <<'END_OF_FUNC', |
| 165 | | | | | sub MethPost { |
| 166 | | | | | return request_method() eq 'POST'; |
| 167 | | | | | } |
| 168 | | | | | END_OF_FUNC |
| 169 | | | | | |
| 170 | | | | | 'MethPut' => <<'END_OF_FUNC', |
| 171 | | | | | sub MethPut { |
| 172 | | | | | return request_method() eq 'PUT'; |
| 173 | | | | | } |
| 174 | | | | | END_OF_FUNC |
| 175 | | | | | |
| 176 | | | | | 'TIEHASH' => <<'END_OF_FUNC', |
| 177 | | | | | sub TIEHASH { |
| 178 | | | | | my $class = shift; |
| 179 | | | | | my $arg = $_[0]; |
| 180 | | | | | if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) { |
| 181 | | | | | return $arg; |
| 182 | | | | | } |
| 183 | | | | | return $Q ||= $class->new(@_); |
| 184 | | | | | } |
| 185 | | | | | END_OF_FUNC |
| 186 | | | | | |
| 187 | | | | | 'STORE' => <<'END_OF_FUNC', |
| 188 | | | | | sub STORE { |
| 189 | | | | | my $self = shift; |
| 190 | | | | | my $tag = shift; |
| 191 | | | | | my $vals = shift; |
| 192 | | | | | my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals; |
| 193 | | | | | $self->param(-name=>$tag,-value=>\@vals); |
| 194 | | | | | } |
| 195 | | | | | END_OF_FUNC |
| 196 | | | | | |
| 197 | | | | | 'FETCH' => <<'END_OF_FUNC', |
| 198 | | | | | sub FETCH { |
| 199 | | | | | return $_[0] if $_[1] eq 'CGI'; |
| 200 | | | | | return undef unless defined $_[0]->param($_[1]); |
| 201 | | | | | return join("\0",$_[0]->param($_[1])); |
| 202 | | | | | } |
| 203 | | | | | END_OF_FUNC |
| 204 | | | | | |
| 205 | | | | | 'FIRSTKEY' => <<'END_OF_FUNC', |
| 206 | | | | | sub FIRSTKEY { |
| 207 | | | | | $_[0]->{'.iterator'}=0; |
| 208 | | | | | $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; |
| 209 | | | | | } |
| 210 | | | | | END_OF_FUNC |
| 211 | | | | | |
| 212 | | | | | 'NEXTKEY' => <<'END_OF_FUNC', |
| 213 | | | | | sub NEXTKEY { |
| 214 | | | | | $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; |
| 215 | | | | | } |
| 216 | | | | | END_OF_FUNC |
| 217 | | | | | |
| 218 | | | | | 'EXISTS' => <<'END_OF_FUNC', |
| 219 | | | | | sub EXISTS { |
| 220 | | | | | exists $_[0]->{param}{$_[1]}; |
| 221 | | | | | } |
| 222 | | | | | END_OF_FUNC |
| 223 | | | | | |
| 224 | | | | | 'DELETE' => <<'END_OF_FUNC', |
| 225 | | | | | sub DELETE { |
| 226 | | | | | my ($self, $param) = @_; |
| 227 | | | | | my $value = $self->FETCH($param); |
| 228 | | | | | $self->delete($param); |
| 229 | | | | | return $value; |
| 230 | | | | | } |
| 231 | | | | | END_OF_FUNC |
| 232 | | | | | |
| 233 | | | | | 'CLEAR' => <<'END_OF_FUNC', |
| 234 | | | | | sub CLEAR { |
| 235 | | | | | %{$_[0]}=(); |
| 236 | | | | | } |
| 237 | | | | | #### |
| 238 | | | | | END_OF_FUNC |
| 239 | | | | | |
| 240 | | | | | #### |
| 241 | | | | | # Append a new value to an existing query |
| 242 | | | | | #### |
| 243 | | | | | 'append' => <<'EOF', |
| 244 | | | | | sub append { |
| 245 | | | | | my($self,@p) = self_or_default(@_); |
| 246 | | | | | my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p); |
| 247 | | | | | my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : (); |
| 248 | | | | | if (@values) { |
| 249 | | | | | $self->add_parameter($name); |
| 250 | | | | | push(@{$self->{param}{$name}},@values); |
| 251 | | | | | } |
| 252 | | | | | return $self->param($name); |
| 253 | | | | | } |
| 254 | | | | | EOF |
| 255 | | | | | |
| 256 | | | | | #### Method: delete_all |
| 257 | | | | | # Delete all parameters |
| 258 | | | | | #### |
| 259 | | | | | 'delete_all' => <<'EOF', |
| 260 | | | | | sub delete_all { |
| 261 | | | | | my($self) = self_or_default(@_); |
| 262 | | | | | my @param = $self->param(); |
| 263 | | | | | $self->delete(@param); |
| 264 | | | | | } |
| 265 | | | | | EOF |
| 266 | | | | | |
| 267 | | | | | 'Delete' => <<'EOF', |
| 268 | | | | | sub Delete { |
| 269 | | | | | my($self,@p) = self_or_default(@_); |
| 270 | | | | | $self->delete(@p); |
| 271 | | | | | } |
| 272 | | | | | EOF |
| 273 | | | | | |
| 274 | | | | | 'Delete_all' => <<'EOF', |
| 275 | | | | | sub Delete_all { |
| 276 | | | | | my($self,@p) = self_or_default(@_); |
| 277 | | | | | $self->delete_all(@p); |
| 278 | | | | | } |
| 279 | | | | | EOF |
| 280 | | | | | |
| 281 | | | | | #### Method: autoescape |
| 282 | | | | | # If you want to turn off the autoescaping features, |
| 283 | | | | | # call this method with undef as the argument |
| 284 | | | | | 'autoEscape' => <<'END_OF_FUNC', |
| 285 | | | | | sub autoEscape { |
| 286 | | | | | my($self,$escape) = self_or_default(@_); |
| 287 | | | | | my $d = $self->{'escape'}; |
| 288 | | | | | $self->{'escape'} = $escape; |
| 289 | | | | | $d; |
| 290 | | | | | } |
| 291 | | | | | END_OF_FUNC |
| 292 | | | | | |
| 293 | | | | | |
| 294 | | | | | #### Method: version |
| 295 | | | | | # Return the current version |
| 296 | | | | | #### |
| 297 | | | | | 'version' => <<'END_OF_FUNC', |
| 298 | | | | | sub version { |
| 299 | | | | | return $VERSION; |
| 300 | | | | | } |
| 301 | | | | | END_OF_FUNC |
| 302 | | | | | |
| 303 | | | | | #### Method: url_param |
| 304 | | | | | # Return a parameter in the QUERY_STRING, regardless of |
| 305 | | | | | # whether this was a POST or a GET |
| 306 | | | | | #### |
| 307 | | | | | 'url_param' => <<'END_OF_FUNC', |
| 308 | | | | | sub url_param { |
| 309 | | | | | my ($self,@p) = self_or_default(@_); |
| 310 | | | | | my $name = shift(@p); |
| 311 | | | | | return undef unless exists($ENV{QUERY_STRING}); |
| 312 | | | | | unless (exists($self->{'.url_param'})) { |
| 313 | | | | | $self->{'.url_param'}={}; # empty hash |
| 314 | | | | | if ($ENV{QUERY_STRING} =~ /=/) { |
| 315 | | | | | my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING}); |
| 316 | | | | | my($param,$value); |
| 317 | | | | | for (@pairs) { |
| 318 | | | | | ($param,$value) = split('=',$_,2); |
| 319 | | | | | next if ! defined($param); |
| 320 | | | | | $param = unescape($param); |
| 321 | | | | | $value = unescape($value); |
| 322 | | | | | push(@{$self->{'.url_param'}->{$param}},$value); |
| 323 | | | | | } |
| 324 | | | | | } else { |
| 325 | | | | | my @keywords = $self->parse_keywordlist($ENV{QUERY_STRING}); |
| 326 | | | | | $self->{'.url_param'}{'keywords'} = \@keywords if @keywords; |
| 327 | | | | | } |
| 328 | | | | | } |
| 329 | | | | | return keys %{$self->{'.url_param'}} unless defined($name); |
| 330 | | | | | return () unless $self->{'.url_param'}->{$name}; |
| 331 | | | | | return wantarray ? @{$self->{'.url_param'}->{$name}} |
| 332 | | | | | : $self->{'.url_param'}->{$name}->[0]; |
| 333 | | | | | } |
| 334 | | | | | END_OF_FUNC |
| 335 | | | | | |
| 336 | | | | | #### Method: Dump |
| 337 | | | | | # Returns a string in which all the known parameter/value |
| 338 | | | | | # pairs are represented as nested lists, mainly for the purposes |
| 339 | | | | | # of debugging. |
| 340 | | | | | #### |
| 341 | | | | | 'Dump' => <<'END_OF_FUNC', |
| 342 | | | | | sub Dump { |
| 343 | | | | | my($self) = self_or_default(@_); |
| 344 | | | | | my($param,$value,@result); |
| 345 | | | | | return '<ul></ul>' unless $self->param; |
| 346 | | | | | push(@result,"<ul>"); |
| 347 | | | | | for $param ($self->param) { |
| 348 | | | | | my($name)=$self->_maybe_escapeHTML($param); |
| 349 | | | | | push(@result,"<li><strong>$name</strong></li>"); |
| 350 | | | | | push(@result,"<ul>"); |
| 351 | | | | | for $value ($self->param($param)) { |
| 352 | | | | | $value = $self->_maybe_escapeHTML($value); |
| 353 | | | | | $value =~ s/\n/<br \/>\n/g; |
| 354 | | | | | push(@result,"<li>$value</li>"); |
| 355 | | | | | } |
| 356 | | | | | push(@result,"</ul>"); |
| 357 | | | | | } |
| 358 | | | | | push(@result,"</ul>"); |
| 359 | | | | | return join("\n",@result); |
| 360 | | | | | } |
| 361 | | | | | END_OF_FUNC |
| 362 | | | | | |
| 363 | | | | | #### Method as_string |
| 364 | | | | | # |
| 365 | | | | | # synonym for "dump" |
| 366 | | | | | #### |
| 367 | | | | | 'as_string' => <<'END_OF_FUNC', |
| 368 | | | | | sub as_string { |
| 369 | | | | | &Dump(@_); |
| 370 | | | | | } |
| 371 | | | | | END_OF_FUNC |
| 372 | | | | | |
| 373 | | | | | #### Method: save |
| 374 | | | | | # Write values out to a filehandle in such a way that they can |
| 375 | | | | | # be reinitialized by the filehandle form of the new() method |
| 376 | | | | | #### |
| 377 | | | | | 'save' => <<'END_OF_FUNC', |
| 378 | | | | | sub save { |
| 379 | | | | | my($self,$filehandle) = self_or_default(@_); |
| 380 | | | | | $filehandle = to_filehandle($filehandle); |
| 381 | | | | | my($param); |
| 382 | | | | | local($,) = ''; # set print field separator back to a sane value |
| 383 | | | | | local($\) = ''; # set output line separator to a sane value |
| 384 | | | | | for $param ($self->param) { |
| 385 | | | | | my($escaped_param) = escape($param); |
| 386 | | | | | my($value); |
| 387 | | | | | for $value ($self->param($param)) { |
| 388 | | | | | print $filehandle "$escaped_param=",escape("$value"),"\n" |
| 389 | | | | | if length($escaped_param) or length($value); |
| 390 | | | | | } |
| 391 | | | | | } |
| 392 | | | | | for (keys %{$self->{'.fieldnames'}}) { |
| 393 | | | | | print $filehandle ".cgifields=",escape("$_"),"\n"; |
| 394 | | | | | } |
| 395 | | | | | print $filehandle "=\n"; # end of record |
| 396 | | | | | } |
| 397 | | | | | END_OF_FUNC |
| 398 | | | | | |
| 399 | | | | | |
| 400 | | | | | #### Method: save_parameters |
| 401 | | | | | # An alias for save() that is a better name for exportation. |
| 402 | | | | | # Only intended to be used with the function (non-OO) interface. |
| 403 | | | | | #### |
| 404 | | | | | 'save_parameters' => <<'END_OF_FUNC', |
| 405 | | | | | sub save_parameters { |
| 406 | | | | | my $fh = shift; |
| 407 | | | | | return save(to_filehandle($fh)); |
| 408 | | | | | } |
| 409 | | | | | END_OF_FUNC |
| 410 | | | | | |
| 411 | | | | | #### Method: restore_parameters |
| 412 | | | | | # A way to restore CGI parameters from an initializer. |
| 413 | | | | | # Only intended to be used with the function (non-OO) interface. |
| 414 | | | | | #### |
| 415 | | | | | 'restore_parameters' => <<'END_OF_FUNC', |
| 416 | | | | | sub restore_parameters { |
| 417 | | | | | $Q = $CGI::DefaultClass->new(@_); |
| 418 | | | | | } |
| 419 | | | | | END_OF_FUNC |
| 420 | | | | | |
| 421 | | | | | #### Method: multipart_init |
| 422 | | | | | # Return a Content-Type: style header for server-push |
| 423 | | | | | # This has to be NPH on most web servers, and it is advisable to set $| = 1 |
| 424 | | | | | # |
| 425 | | | | | # Many thanks to Ed Jordan <ed@fidalgo.net> for this |
| 426 | | | | | # contribution, updated by Andrew Benham (adsb@bigfoot.com) |
| 427 | | | | | #### |
| 428 | | | | | 'multipart_init' => <<'END_OF_FUNC', |
| 429 | | | | | sub multipart_init { |
| 430 | | | | | my($self,@p) = self_or_default(@_); |
| 431 | | | | | my($boundary,$charset,@other) = rearrange_header([BOUNDARY,CHARSET],@p); |
| 432 | | | | | if (!$boundary) { |
| 433 | | | | | $boundary = '------- =_'; |
| 434 | | | | | my @chrs = ('0'..'9', 'A'..'Z', 'a'..'z'); |
| 435 | | | | | for (1..17) { |
| 436 | | | | | $boundary .= $chrs[rand(scalar @chrs)]; |
| 437 | | | | | } |
| 438 | | | | | } |
| 439 | | | | | |
| 440 | | | | | $self->{'separator'} = "$CRLF--$boundary$CRLF"; |
| 441 | | | | | $self->{'final_separator'} = "$CRLF--$boundary--$CRLF"; |
| 442 | | | | | $type = SERVER_PUSH($boundary); |
| 443 | | | | | return $self->header( |
| 444 | | | | | -nph => 0, |
| 445 | | | | | -type => $type, |
| 446 | | | | | -charset => $charset, |
| 447 | | | | | (map { split "=", $_, 2 } @other), |
| 448 | | | | | ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end; |
| 449 | | | | | } |
| 450 | | | | | END_OF_FUNC |
| 451 | | | | | |
| 452 | | | | | |
| 453 | | | | | #### Method: multipart_start |
| 454 | | | | | # Return a Content-Type: style header for server-push, start of section |
| 455 | | | | | # |
| 456 | | | | | # Many thanks to Ed Jordan <ed@fidalgo.net> for this |
| 457 | | | | | # contribution, updated by Andrew Benham (adsb@bigfoot.com) |
| 458 | | | | | #### |
| 459 | | | | | 'multipart_start' => <<'END_OF_FUNC', |
| 460 | | | | | sub multipart_start { |
| 461 | | | | | my(@header); |
| 462 | | | | | my($self,@p) = self_or_default(@_); |
| 463 | | | | | my($type,$charset,@other) = rearrange([TYPE,CHARSET],@p); |
| 464 | | | | | $type = $type || 'text/html'; |
| 465 | | | | | if ($charset) { |
| 466 | | | | | push(@header,"Content-Type: $type; charset=$charset"); |
| 467 | | | | | } else { |
| 468 | | | | | push(@header,"Content-Type: $type"); |
| 469 | | | | | } |
| 470 | | | | | |
| 471 | | | | | # rearrange() was designed for the HTML portion, so we |
| 472 | | | | | # need to fix it up a little. |
| 473 | | | | | for (@other) { |
| 474 | | | | | # Don't use \s because of perl bug 21951 |
| 475 | | | | | next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/; |
| 476 | | | | | ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e; |
| 477 | | | | | } |
| 478 | | | | | push(@header,@other); |
| 479 | | | | | my $header = join($CRLF,@header)."${CRLF}${CRLF}"; |
| 480 | | | | | return $header; |
| 481 | | | | | } |
| 482 | | | | | END_OF_FUNC |
| 483 | | | | | |
| 484 | | | | | |
| 485 | | | | | #### Method: multipart_end |
| 486 | | | | | # Return a MIME boundary separator for server-push, end of section |
| 487 | | | | | # |
| 488 | | | | | # Many thanks to Ed Jordan <ed@fidalgo.net> for this |
| 489 | | | | | # contribution |
| 490 | | | | | #### |
| 491 | | | | | 'multipart_end' => <<'END_OF_FUNC', |
| 492 | | | | | sub multipart_end { |
| 493 | | | | | my($self,@p) = self_or_default(@_); |
| 494 | | | | | return $self->{'separator'}; |
| 495 | | | | | } |
| 496 | | | | | END_OF_FUNC |
| 497 | | | | | |
| 498 | | | | | |
| 499 | | | | | #### Method: multipart_final |
| 500 | | | | | # Return a MIME boundary separator for server-push, end of all sections |
| 501 | | | | | # |
| 502 | | | | | # Contributed by Andrew Benham (adsb@bigfoot.com) |
| 503 | | | | | #### |
| 504 | | | | | 'multipart_final' => <<'END_OF_FUNC', |
| 505 | | | | | sub multipart_final { |
| 506 | | | | | my($self,@p) = self_or_default(@_); |
| 507 | | | | | return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF; |
| 508 | | | | | } |
| 509 | | | | | END_OF_FUNC |
| 510 | | | | | |
| 511 | | | | | |
| 512 | | | | | #### Method: header |
| 513 | | | | | # Return a Content-Type: style header |
| 514 | | | | | # |
| 515 | | | | | #### |
| 516 | | | | | 'header' => <<'END_OF_FUNC', |
| 517 | | | | | sub header { |
| 518 | | | | | my($self,@p) = self_or_default(@_); |
| 519 | | | | | my(@header); |
| 520 | | | | | |
| 521 | | | | | return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE; |
| 522 | | | | | |
| 523 | | | | | my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) = |
| 524 | | | | | rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], |
| 525 | | | | | 'STATUS',['COOKIE','COOKIES','SET-COOKIE'],'TARGET', |
| 526 | | | | | 'EXPIRES','NPH','CHARSET', |
| 527 | | | | | 'ATTACHMENT','P3P'],@p); |
| 528 | | | | | |
| 529 | | | | | # Since $cookie and $p3p may be array references, |
| 530 | | | | | # we must stringify them before CR escaping is done. |
| 531 | | | | | my @cookie; |
| 532 | | | | | for (ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie) { |
| 533 | | | | | my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_; |
| 534 | | | | | push(@cookie,$cs) if defined $cs and $cs ne ''; |
| 535 | | | | | } |
| 536 | | | | | $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY'; |
| 537 | | | | | |
| 538 | | | | | # CR escaping for values, per RFC 822 |
| 539 | | | | | for my $header ($type,$status,@cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) { |
| 540 | | | | | if (defined $header) { |
| 541 | | | | | # From RFC 822: |
| 542 | | | | | # Unfolding is accomplished by regarding CRLF immediately |
| 543 | | | | | # followed by a LWSP-char as equivalent to the LWSP-char. |
| 544 | | | | | $header =~ s/$CRLF(\s)/$1/g; |
| 545 | | | | | |
| 546 | | | | | # All other uses of newlines are invalid input. |
| 547 | | | | | if ($header =~ m/$CRLF|\015|\012/) { |
| 548 | | | | | # shorten very long values in the diagnostic |
| 549 | | | | | $header = substr($header,0,72).'...' if (length $header > 72); |
| 550 | | | | | die "Invalid header value contains a newline not followed by whitespace: $header"; |
| 551 | | | | | } |
| 552 | | | | | } |
| 553 | | | | | } |
| 554 | | | | | |
| 555 | | | | | $nph ||= $NPH; |
| 556 | | | | | |
| 557 | | | | | $type ||= 'text/html' unless defined($type); |
| 558 | | | | | |
| 559 | | | | | # sets if $charset is given, gets if not |
| 560 | | | | | $charset = $self->charset( $charset ); |
| 561 | | | | | |
| 562 | | | | | # rearrange() was designed for the HTML portion, so we |
| 563 | | | | | # need to fix it up a little. |
| 564 | | | | | for (@other) { |
| 565 | | | | | # Don't use \s because of perl bug 21951 |
| 566 | | | | | next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s; |
| 567 | | | | | ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e; |
| 568 | | | | | } |
| 569 | | | | | |
| 570 | | | | | $type .= "; charset=$charset" |
| 571 | | | | | if $type ne '' |
| 572 | | | | | and $type !~ /\bcharset\b/ |
| 573 | | | | | and defined $charset |
| 574 | | | | | and $charset ne ''; |
| 575 | | | | | |
| 576 | | | | | # Maybe future compatibility. Maybe not. |
| 577 | | | | | my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; |
| 578 | | | | | push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph; |
| 579 | | | | | push(@header,"Server: " . &server_software()) if $nph; |
| 580 | | | | | |
| 581 | | | | | push(@header,"Status: $status") if $status; |
| 582 | | | | | push(@header,"Window-Target: $target") if $target; |
| 583 | | | | | push(@header,"P3P: policyref=\"/w3c/p3p.xml\", CP=\"$p3p\"") if $p3p; |
| 584 | | | | | # push all the cookies -- there may be several |
| 585 | | | | | push(@header,map {"Set-Cookie: $_"} @cookie); |
| 586 | | | | | # if the user indicates an expiration time, then we need |
| 587 | | | | | # both an Expires and a Date header (so that the browser is |
| 588 | | | | | # uses OUR clock) |
| 589 | | | | | push(@header,"Expires: " . expires($expires,'http')) |
| 590 | | | | | if $expires; |
| 591 | | | | | push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph; |
| 592 | | | | | push(@header,"Pragma: no-cache") if $self->cache(); |
| 593 | | | | | push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment; |
| 594 | | | | | push(@header,map {ucfirst $_} @other); |
| 595 | | | | | push(@header,"Content-Type: $type") if $type ne ''; |
| 596 | | | | | my $header = join($CRLF,@header)."${CRLF}${CRLF}"; |
| 597 | | | | | if (($MOD_PERL >= 1) && !$nph) { |
| 598 | | | | | $self->r->send_cgi_header($header); |
| 599 | | | | | return ''; |
| 600 | | | | | } |
| 601 | | | | | return $header; |
| 602 | | | | | } |
| 603 | | | | | END_OF_FUNC |
| 604 | | | | | |
| 605 | | | | | #### Method: cache |
| 606 | | | | | # Control whether header() will produce the no-cache |
| 607 | | | | | # Pragma directive. |
| 608 | | | | | #### |
| 609 | | | | | 'cache' => <<'END_OF_FUNC', |
| 610 | | | | | sub cache { |
| 611 | | | | | my($self,$new_value) = self_or_default(@_); |
| 612 | | | | | $new_value = '' unless $new_value; |
| 613 | | | | | if ($new_value ne '') { |
| 614 | | | | | $self->{'cache'} = $new_value; |
| 615 | | | | | } |
| 616 | | | | | return $self->{'cache'}; |
| 617 | | | | | } |
| 618 | | | | | END_OF_FUNC |
| 619 | | | | | |
| 620 | | | | | |
| 621 | | | | | #### Method: redirect |
| 622 | | | | | # Return a Location: style header |
| 623 | | | | | # |
| 624 | | | | | #### |
| 625 | | | | | 'redirect' => <<'END_OF_FUNC', |
| 626 | | | | | sub redirect { |
| 627 | | | | | my($self,@p) = self_or_default(@_); |
| 628 | | | | | my($url,$target,$status,$cookie,$nph,@other) = |
| 629 | | | | | rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES','SET-COOKIE'],NPH],@p); |
| 630 | | | | | $status = '302 Found' unless defined $status; |
| 631 | | | | | $url ||= $self->self_url; |
| 632 | | | | | my(@o); |
| 633 | | | | | for (@other) { tr/\"//d; push(@o,split("=",$_,2)); } |
| 634 | | | | | unshift(@o, |
| 635 | | | | | '-Status' => $status, |
| 636 | | | | | '-Location'=> $url, |
| 637 | | | | | '-nph' => $nph); |
| 638 | | | | | unshift(@o,'-Target'=>$target) if $target; |
| 639 | | | | | unshift(@o,'-Type'=>''); |
| 640 | | | | | my @unescaped; |
| 641 | | | | | unshift(@unescaped,'-Cookie'=>$cookie) if $cookie; |
| 642 | | | | | return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped); |
| 643 | | | | | } |
| 644 | | | | | END_OF_FUNC |
| 645 | | | | | |
| 646 | | | | | |
| 647 | | | | | #### Method: start_html |
| 648 | | | | | # Canned HTML header |
| 649 | | | | | # |
| 650 | | | | | # Parameters: |
| 651 | | | | | # $title -> (optional) The title for this HTML document (-title) |
| 652 | | | | | # $author -> (optional) e-mail address of the author (-author) |
| 653 | | | | | # $base -> (optional) if set to true, will enter the BASE address of this document |
| 654 | | | | | # for resolving relative references (-base) |
| 655 | | | | | # $xbase -> (optional) alternative base at some remote location (-xbase) |
| 656 | | | | | # $target -> (optional) target window to load all links into (-target) |
| 657 | | | | | # $script -> (option) Javascript code (-script) |
| 658 | | | | | # $no_script -> (option) Javascript <noscript> tag (-noscript) |
| 659 | | | | | # $meta -> (optional) Meta information tags |
| 660 | | | | | # $head -> (optional) any other elements you'd like to incorporate into the <head> tag |
| 661 | | | | | # (a scalar or array ref) |
| 662 | | | | | # $style -> (optional) reference to an external style sheet |
| 663 | | | | | # @other -> (optional) any other named parameters you'd like to incorporate into |
| 664 | | | | | # the <body> tag. |
| 665 | | | | | #### |
| 666 | | | | | 'start_html' => <<'END_OF_FUNC', |
| 667 | | | | | sub start_html { |
| 668 | | | | | my($self,@p) = &self_or_default(@_); |
| 669 | | | | | my($title,$author,$base,$xbase,$script,$noscript, |
| 670 | | | | | $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) = |
| 671 | | | | | rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET, |
| 672 | | | | | META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p); |
| 673 | | | | | |
| 674 | | | | | $self->element_id(0); |
| 675 | | | | | $self->element_tab(0); |
| 676 | | | | | |
| 677 | | | | | $encoding = lc($self->charset) unless defined $encoding; |
| 678 | | | | | |
| 679 | | | | | # Need to sort out the DTD before it's okay to call escapeHTML(). |
| 680 | | | | | my(@result,$xml_dtd); |
| 681 | | | | | if ($dtd) { |
| 682 | | | | | if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) { |
| 683 | | | | | $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|; |
| 684 | | | | | } else { |
| 685 | | | | | $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|; |
| 686 | | | | | } |
| 687 | | | | | } else { |
| 688 | | | | | $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD; |
| 689 | | | | | } |
| 690 | | | | | |
| 691 | | | | | $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i; |
| 692 | | | | | $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i; |
| 693 | | | | | push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml; |
| 694 | | | | | |
| 695 | | | | | if (ref($dtd) && ref($dtd) eq 'ARRAY') { |
| 696 | | | | | push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">)); |
| 697 | | | | | $DTD_PUBLIC_IDENTIFIER = $dtd->[0]; |
| 698 | | | | | } else { |
| 699 | | | | | push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">)); |
| 700 | | | | | $DTD_PUBLIC_IDENTIFIER = $dtd; |
| 701 | | | | | } |
| 702 | | | | | |
| 703 | | | | | # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to |
| 704 | | | | | # call escapeHTML(). Strangely enough, the title needs to be escaped as |
| 705 | | | | | # HTML while the author needs to be escaped as a URL. |
| 706 | | | | | $title = $self->_maybe_escapeHTML($title || 'Untitled Document'); |
| 707 | | | | | $author = $self->escape($author); |
| 708 | | | | | |
| 709 | | | | | if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2|4\.01?)/i) { |
| 710 | | | | | $lang = "" unless defined $lang; |
| 711 | | | | | $XHTML = 0; |
| 712 | | | | | } |
| 713 | | | | | else { |
| 714 | | | | | $lang = 'en-US' unless defined $lang; |
| 715 | | | | | } |
| 716 | | | | | |
| 717 | | | | | my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : ''; |
| 718 | | | | | my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />) |
| 719 | | | | | if $XHTML && $encoding && !$declare_xml; |
| 720 | | | | | |
| 721 | | | | | push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>) |
| 722 | | | | | : ($lang ? qq(<html lang="$lang">) : "<html>") |
| 723 | | | | | . "<head><title>$title</title>"); |
| 724 | | | | | if (defined $author) { |
| 725 | | | | | push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />" |
| 726 | | | | | : "<link rev=\"made\" href=\"mailto:$author\">"); |
| 727 | | | | | } |
| 728 | | | | | |
| 729 | | | | | if ($base || $xbase || $target) { |
| 730 | | | | | my $href = $xbase || $self->url('-path'=>1); |
| 731 | | | | | my $t = $target ? qq/ target="$target"/ : ''; |
| 732 | | | | | push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>)); |
| 733 | | | | | } |
| 734 | | | | | |
| 735 | | | | | if ($meta && ref($meta) && (ref($meta) eq 'HASH')) { |
| 736 | | | | | for (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />) |
| 737 | | | | | : qq(<meta name="$_" content="$meta->{$_}">)); } |
| 738 | | | | | } |
| 739 | | | | | |
| 740 | | | | | my $meta_bits_set = 0; |
| 741 | | | | | if( $head ) { |
| 742 | | | | | if( ref $head ) { |
| 743 | | | | | push @result, @$head; |
| 744 | | | | | $meta_bits_set = 1 if grep { /http-equiv=["']Content-Type/i }@$head; |
| 745 | | | | | } |
| 746 | | | | | else { |
| 747 | | | | | push @result, $head; |
| 748 | | | | | $meta_bits_set = 1 if $head =~ /http-equiv=["']Content-Type/i; |
| 749 | | | | | } |
| 750 | | | | | } |
| 751 | | | | | |
| 752 | | | | | # handle the infrequently-used -style and -script parameters |
| 753 | | | | | push(@result,$self->_style($style)) if defined $style; |
| 754 | | | | | push(@result,$self->_script($script)) if defined $script; |
| 755 | | | | | push(@result,$meta_bits) if defined $meta_bits and !$meta_bits_set; |
| 756 | | | | | |
| 757 | | | | | # handle -noscript parameter |
| 758 | | | | | push(@result,<<END) if $noscript; |
| 759 | | | | | <noscript> |
| 760 | | | | | $noscript |
| 761 | | | | | </noscript> |
| 762 | | | | | END |
| 763 | | | | | ; |
| 764 | | | | | my($other) = @other ? " @other" : ''; |
| 765 | | | | | push(@result,"</head>\n<body$other>\n"); |
| 766 | | | | | return join("\n",@result); |
| 767 | | | | | } |
| 768 | | | | | END_OF_FUNC |
| 769 | | | | | |
| 770 | | | | | ### Method: _style |
| 771 | | | | | # internal method for generating a CSS style section |
| 772 | | | | | #### |
| 773 | | | | | '_style' => <<'END_OF_FUNC', |
| 774 | | | | | sub _style { |
| 775 | | | | | my ($self,$style) = @_; |
| 776 | | | | | my (@result); |
| 777 | | | | | |
| 778 | | | | | my $type = 'text/css'; |
| 779 | | | | | my $rel = 'stylesheet'; |
| 780 | | | | | |
| 781 | | | | | |
| 782 | | | | | my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- "; |
| 783 | | | | | my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n"; |
| 784 | | | | | |
| 785 | | | | | my @s = ref($style) eq 'ARRAY' ? @$style : $style; |
| 786 | | | | | my $other = ''; |
| 787 | | | | | |
| 788 | | | | | for my $s (@s) { |
| 789 | | | | | if (ref($s)) { |
| 790 | | | | | my($src,$code,$verbatim,$stype,$alternate,$foo,@other) = |
| 791 | | | | | rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)], |
| 792 | | | | | ('-foo'=>'bar', |
| 793 | | | | | ref($s) eq 'ARRAY' ? @$s : %$s)); |
| 794 | | | | | my $type = defined $stype ? $stype : 'text/css'; |
| 795 | | | | | my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet'; |
| 796 | | | | | $other = "@other" if @other; |
| 797 | | | | | |
| 798 | | | | | if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference |
| 799 | | | | | { # If it is, push a LINK tag for each one |
| 800 | | | | | for $src (@$src) |
| 801 | | | | | { |
| 802 | | | | | push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>) |
| 803 | | | | | : qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src; |
| 804 | | | | | } |
| 805 | | | | | } |
| 806 | | | | | else |
| 807 | | | | | { # Otherwise, push the single -src, if it exists. |
| 808 | | | | | push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>) |
| 809 | | | | | : qq(<link rel="$rel" type="$type" href="$src"$other>) |
| 810 | | | | | ) if $src; |
| 811 | | | | | } |
| 812 | | | | | if ($verbatim) { |
| 813 | | | | | my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim; |
| 814 | | | | | push(@result, "<style type=\"text/css\">\n$_\n</style>") for @v; |
| 815 | | | | | } |
| 816 | | | | | if ($code) { |
| 817 | | | | | my @c = ref($code) eq 'ARRAY' ? @$code : $code; |
| 818 | | | | | push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c; |
| 819 | | | | | } |
| 820 | | | | | |
| 821 | | | | | } else { |
| 822 | | | | | my $src = $s; |
| 823 | | | | | push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>) |
| 824 | | | | | : qq(<link rel="$rel" type="$type" href="$src"$other>)); |
| 825 | | | | | } |
| 826 | | | | | } |
| 827 | | | | | @result; |
| 828 | | | | | } |
| 829 | | | | | END_OF_FUNC |
| 830 | | | | | |
| 831 | | | | | '_script' => <<'END_OF_FUNC', |
| 832 | | | | | sub _script { |
| 833 | | | | | my ($self,$script) = @_; |
| 834 | | | | | my (@result); |
| 835 | | | | | |
| 836 | | | | | my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script); |
| 837 | | | | | for $script (@scripts) { |
| 838 | | | | | my($src,$code,$language,$charset); |
| 839 | | | | | if (ref($script)) { # script is a hash |
| 840 | | | | | ($src,$code,$type,$charset) = |
| 841 | | | | | rearrange(['SRC','CODE',['LANGUAGE','TYPE'],'CHARSET'], |
| 842 | | | | | '-foo'=>'bar', # a trick to allow the '-' to be omitted |
| 843 | | | | | ref($script) eq 'ARRAY' ? @$script : %$script); |
| 844 | | | | | $type ||= 'text/javascript'; |
| 845 | | | | | unless ($type =~ m!\w+/\w+!) { |
| 846 | | | | | $type =~ s/[\d.]+$//; |
| 847 | | | | | $type = "text/$type"; |
| 848 | | | | | } |
| 849 | | | | | } else { |
| 850 | | | | | ($src,$code,$type,$charset) = ('',$script, 'text/javascript', ''); |
| 851 | | | | | } |
| 852 | | | | | |
| 853 | | | | | my $comment = '//'; # javascript by default |
| 854 | | | | | $comment = '#' if $type=~/perl|tcl/i; |
| 855 | | | | | $comment = "'" if $type=~/vbscript/i; |
| 856 | | | | | |
| 857 | | | | | my ($cdata_start,$cdata_end); |
| 858 | | | | | if ($XHTML) { |
| 859 | | | | | $cdata_start = "$comment<![CDATA[\n"; |
| 860 | | | | | $cdata_end .= "\n$comment]]>"; |
| 861 | | | | | } else { |
| 862 | | | | | $cdata_start = "\n<!-- Hide script\n"; |
| 863 | | | | | $cdata_end = $comment; |
| 864 | | | | | $cdata_end .= " End script hiding -->\n"; |
| 865 | | | | | } |
| 866 | | | | | my(@satts); |
| 867 | | | | | push(@satts,'src'=>$src) if $src; |
| 868 | | | | | push(@satts,'type'=>$type); |
| 869 | | | | | push(@satts,'charset'=>$charset) if ($src && $charset); |
| 870 | | | | | $code = $cdata_start . $code . $cdata_end if defined $code; |
| 871 | | | | | push(@result,$self->script({@satts},$code || '')); |
| 872 | | | | | } |
| 873 | | | | | @result; |
| 874 | | | | | } |
| 875 | | | | | END_OF_FUNC |
| 876 | | | | | |
| 877 | | | | | #### Method: end_html |
| 878 | | | | | # End an HTML document. |
| 879 | | | | | # Trivial method for completeness. Just returns "</body>" |
| 880 | | | | | #### |
| 881 | | | | | 'end_html' => <<'END_OF_FUNC', |
| 882 | | | | | sub end_html { |
| 883 | | | | | return "\n</body>\n</html>"; |
| 884 | | | | | } |
| 885 | | | | | END_OF_FUNC |
| 886 | | | | | |
| 887 | | | | | |
| 888 | | | | | ################################ |
| 889 | | | | | # METHODS USED IN BUILDING FORMS |
| 890 | | | | | ################################ |
| 891 | | | | | |
| 892 | | | | | #### Method: isindex |
| 893 | | | | | # Just prints out the isindex tag. |
| 894 | | | | | # Parameters: |
| 895 | | | | | # $action -> optional URL of script to run |
| 896 | | | | | # Returns: |
| 897 | | | | | # A string containing a <isindex> tag |
| 898 | | | | | 'isindex' => <<'END_OF_FUNC', |
| 899 | | | | | sub isindex { |
| 900 | | | | | my($self,@p) = self_or_default(@_); |
| 901 | | | | | my($action,@other) = rearrange([ACTION],@p); |
| 902 | | | | | $action = qq/ action="$action"/ if $action; |
| 903 | | | | | my($other) = @other ? " @other" : ''; |
| 904 | | | | | return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>"; |
| 905 | | | | | } |
| 906 | | | | | END_OF_FUNC |
| 907 | | | | | |
| 908 | | | | | |
| 909 | | | | | #### Method: start_form |
| 910 | | | | | # Start a form |
| 911 | | | | | # Parameters: |
| 912 | | | | | # $method -> optional submission method to use (GET or POST) |
| 913 | | | | | # $action -> optional URL of script to run |
| 914 | | | | | # $enctype ->encoding to use (URL_ENCODED or MULTIPART) |
| 915 | | | | | 'start_form' => <<'END_OF_FUNC', |
| 916 | | | | | sub start_form { |
| 917 | | | | | my($self,@p) = self_or_default(@_); |
| 918 | | | | | |
| 919 | | | | | my($method,$action,$enctype,@other) = |
| 920 | | | | | rearrange([METHOD,ACTION,ENCTYPE],@p); |
| 921 | | | | | |
| 922 | | | | | $method = $self->_maybe_escapeHTML(lc($method || 'post')); |
| 923 | | | | | |
| 924 | | | | | if( $XHTML ){ |
| 925 | | | | | $enctype = $self->_maybe_escapeHTML($enctype || &MULTIPART); |
| 926 | | | | | }else{ |
| 927 | | | | | $enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED); |
| 928 | | | | | } |
| 929 | | | | | |
| 930 | | | | | if (defined $action) { |
| 931 | | | | | $action = $self->_maybe_escapeHTML($action); |
| 932 | | | | | } |
| 933 | | | | | else { |
| 934 | | | | | $action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url); |
| 935 | | | | | } |
| 936 | | | | | $action = qq(action="$action"); |
| 937 | | | | | my($other) = @other ? " @other" : ''; |
| 938 | | | | | $self->{'.parametersToAdd'}={}; |
| 939 | | | | | return qq/<form method="$method" $action enctype="$enctype"$other>/; |
| 940 | | | | | } |
| 941 | | | | | END_OF_FUNC |
| 942 | | | | | |
| 943 | | | | | #### Method: start_multipart_form |
| 944 | | | | | 'start_multipart_form' => <<'END_OF_FUNC', |
| 945 | | | | | sub start_multipart_form { |
| 946 | | | | | my($self,@p) = self_or_default(@_); |
| 947 | | | | | if (defined($p[0]) && substr($p[0],0,1) eq '-') { |
| 948 | | | | | return $self->start_form(-enctype=>&MULTIPART,@p); |
| 949 | | | | | } else { |
| 950 | | | | | my($method,$action,@other) = |
| 951 | | | | | rearrange([METHOD,ACTION],@p); |
| 952 | | | | | return $self->start_form($method,$action,&MULTIPART,@other); |
| 953 | | | | | } |
| 954 | | | | | } |
| 955 | | | | | END_OF_FUNC |
| 956 | | | | | |
| - - | | | | | |
| 959 | | | | | #### Method: end_form |
| 960 | | | | | # End a form |
| 961 | | | | | # Note: This repeated below under the older name. |
| 962 | | | | | 'end_form' => <<'END_OF_FUNC', |
| 963 | | | | | sub end_form { |
| 964 | | | | | my($self,@p) = self_or_default(@_); |
| 965 | | | | | if ( $NOSTICKY ) { |
| 966 | | | | | return wantarray ? ("</form>") : "\n</form>"; |
| 967 | | | | | } else { |
| 968 | | | | | if (my @fields = $self->get_fields) { |
| 969 | | | | | return wantarray ? ("<div>",@fields,"</div>","</form>") |
| 970 | | | | | : "<div>".(join '',@fields)."</div>\n</form>"; |
| 971 | | | | | } else { |
| 972 | | | | | return "</form>"; |
| 973 | | | | | } |
| 974 | | | | | } |
| 975 | | | | | } |
| 976 | | | | | END_OF_FUNC |
| 977 | | | | | |
| 978 | | | | | |
| 979 | | | | | #### Method: end_multipart_form |
| 980 | | | | | # end a multipart form |
| 981 | | | | | 'end_multipart_form' => <<'END_OF_FUNC', |
| 982 | | | | | sub end_multipart_form { |
| 983 | | | | | &end_form; |
| 984 | | | | | } |
| 985 | | | | | END_OF_FUNC |
| 986 | | | | | |
| 987 | | | | | |
| 988 | | | | | '_textfield' => <<'END_OF_FUNC', |
| 989 | | | | | sub _textfield { |
| 990 | | | | | my($self,$tag,@p) = self_or_default(@_); |
| 991 | | | | | my($name,$default,$size,$maxlength,$override,$tabindex,@other) = |
| 992 | | | | | rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p); |
| 993 | | | | | |
| 994 | | | | | my $current = $override ? $default : |
| 995 | | | | | (defined($self->param($name)) ? $self->param($name) : $default); |
| 996 | | | | | |
| 997 | | | | | $current = defined($current) ? $self->_maybe_escapeHTML($current,1) : ''; |
| 998 | | | | | $name = defined($name) ? $self->_maybe_escapeHTML($name) : ''; |
| 999 | | | | | my($s) = defined($size) ? qq/ size="$size"/ : ''; |
| 1000 | | | | | my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : ''; |
| 1001 | | | | | my($other) = @other ? " @other" : ''; |
| 1002 | | | | | # this entered at cristy's request to fix problems with file upload fields |
| 1003 | | | | | # and WebTV -- not sure it won't break stuff |
| 1004 | | | | | my($value) = $current ne '' ? qq(value="$current") : ''; |
| 1005 | | | | | $tabindex = $self->element_tab($tabindex); |
| 1006 | | | | | return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />) |
| 1007 | | | | | : qq(<input type="$tag" name="$name" $value$s$m$other>); |
| 1008 | | | | | } |
| 1009 | | | | | END_OF_FUNC |
| 1010 | | | | | |
| 1011 | | | | | #### Method: textfield |
| 1012 | | | | | # Parameters: |
| 1013 | | | | | # $name -> Name of the text field |
| 1014 | | | | | # $default -> Optional default value of the field if not |
| 1015 | | | | | # already defined. |
| 1016 | | | | | # $size -> Optional width of field in characaters. |
| 1017 | | | | | # $maxlength -> Optional maximum number of characters. |
| 1018 | | | | | # Returns: |
| 1019 | | | | | # A string containing a <input type="text"> field |
| 1020 | | | | | # |
| 1021 | | | | | 'textfield' => <<'END_OF_FUNC', |
| 1022 | | | | | sub textfield { |
| 1023 | | | | | my($self,@p) = self_or_default(@_); |
| 1024 | | | | | $self->_textfield('text',@p); |
| 1025 | | | | | } |
| 1026 | | | | | END_OF_FUNC |
| 1027 | | | | | |
| 1028 | | | | | |
| 1029 | | | | | #### Method: filefield |
| 1030 | | | | | # Parameters: |
| 1031 | | | | | # $name -> Name of the file upload field |
| 1032 | | | | | # $size -> Optional width of field in characaters. |
| 1033 | | | | | # $maxlength -> Optional maximum number of characters. |
| 1034 | | | | | # Returns: |
| 1035 | | | | | # A string containing a <input type="file"> field |
| 1036 | | | | | # |
| 1037 | | | | | 'filefield' => <<'END_OF_FUNC', |
| 1038 | | | | | sub filefield { |
| 1039 | | | | | my($self,@p) = self_or_default(@_); |
| 1040 | | | | | $self->_textfield('file',@p); |
| 1041 | | | | | } |
| 1042 | | | | | END_OF_FUNC |
| 1043 | | | | | |
| 1044 | | | | | |
| 1045 | | | | | #### Method: password |
| 1046 | | | | | # Create a "secret password" entry field |
| 1047 | | | | | # Parameters: |
| 1048 | | | | | # $name -> Name of the field |
| 1049 | | | | | # $default -> Optional default value of the field if not |
| 1050 | | | | | # already defined. |
| 1051 | | | | | # $size -> Optional width of field in characters. |
| 1052 | | | | | # $maxlength -> Optional maximum characters that can be entered. |
| 1053 | | | | | # Returns: |
| 1054 | | | | | # A string containing a <input type="password"> field |
| 1055 | | | | | # |
| 1056 | | | | | 'password_field' => <<'END_OF_FUNC', |
| 1057 | | | | | sub password_field { |
| 1058 | | | | | my ($self,@p) = self_or_default(@_); |
| 1059 | | | | | $self->_textfield('password',@p); |
| 1060 | | | | | } |
| 1061 | | | | | END_OF_FUNC |
| 1062 | | | | | |
| 1063 | | | | | #### Method: textarea |
| 1064 | | | | | # Parameters: |
| 1065 | | | | | # $name -> Name of the text field |
| 1066 | | | | | # $default -> Optional default value of the field if not |
| 1067 | | | | | # already defined. |
| 1068 | | | | | # $rows -> Optional number of rows in text area |
| 1069 | | | | | # $columns -> Optional number of columns in text area |
| 1070 | | | | | # Returns: |
| 1071 | | | | | # A string containing a <textarea></textarea> tag |
| 1072 | | | | | # |
| 1073 | | | | | 'textarea' => <<'END_OF_FUNC', |
| 1074 | | | | | sub textarea { |
| 1075 | | | | | my($self,@p) = self_or_default(@_); |
| 1076 | | | | | my($name,$default,$rows,$cols,$override,$tabindex,@other) = |
| 1077 | | | | | rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p); |
| 1078 | | | | | |
| 1079 | | | | | my($current)= $override ? $default : |
| 1080 | | | | | (defined($self->param($name)) ? $self->param($name) : $default); |
| 1081 | | | | | |
| 1082 | | | | | $name = defined($name) ? $self->_maybe_escapeHTML($name) : ''; |
| 1083 | | | | | $current = defined($current) ? $self->_maybe_escapeHTML($current) : ''; |
| 1084 | | | | | my($r) = $rows ? qq/ rows="$rows"/ : ''; |
| 1085 | | | | | my($c) = $cols ? qq/ cols="$cols"/ : ''; |
| 1086 | | | | | my($other) = @other ? " @other" : ''; |
| 1087 | | | | | $tabindex = $self->element_tab($tabindex); |
| 1088 | | | | | return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>}; |
| 1089 | | | | | } |
| 1090 | | | | | END_OF_FUNC |
| 1091 | | | | | |
| 1092 | | | | | |
| 1093 | | | | | #### Method: button |
| 1094 | | | | | # Create a javascript button. |
| 1095 | | | | | # Parameters: |
| 1096 | | | | | # $name -> (optional) Name for the button. (-name) |
| 1097 | | | | | # $value -> (optional) Value of the button when selected (and visible name) (-value) |
| 1098 | | | | | # $onclick -> (optional) Text of the JavaScript to run when the button is |
| 1099 | | | | | # clicked. |
| 1100 | | | | | # Returns: |
| 1101 | | | | | # A string containing a <input type="button"> tag |
| 1102 | | | | | #### |
| 1103 | | | | | 'button' => <<'END_OF_FUNC', |
| 1104 | | | | | sub button { |
| 1105 | | | | | my($self,@p) = self_or_default(@_); |
| 1106 | | | | | |
| 1107 | | | | | my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL], |
| 1108 | | | | | [ONCLICK,SCRIPT],TABINDEX],@p); |
| 1109 | | | | | |
| 1110 | | | | | $label=$self->_maybe_escapeHTML($label); |
| 1111 | | | | | $value=$self->_maybe_escapeHTML($value,1); |
| 1112 | | | | | $script=$self->_maybe_escapeHTML($script); |
| 1113 | | | | | |
| 1114 | | | | | $script ||= ''; |
| 1115 | | | | | |
| 1116 | | | | | my($name) = ''; |
| 1117 | | | | | $name = qq/ name="$label"/ if $label; |
| 1118 | | | | | $value = $value || $label; |
| 1119 | | | | | my($val) = ''; |
| 1120 | | | | | $val = qq/ value="$value"/ if $value; |
| 1121 | | | | | $script = qq/ onclick="$script"/ if $script; |
| 1122 | | | | | my($other) = @other ? " @other" : ''; |
| 1123 | | | | | $tabindex = $self->element_tab($tabindex); |
| 1124 | | | | | return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />) |
| 1125 | | | | | : qq(<input type="button"$name$val$script$other>); |
| 1126 | | | | | } |
| 1127 | | | | | END_OF_FUNC |
| 1128 | | | | | |
| 1129 | | | | | |
| 1130 | | | | | #### Method: submit |
| 1131 | | | | | # Create a "submit query" button. |
| 1132 | | | | | # Parameters: |
| 1133 | | | | | # $name -> (optional) Name for the button. |
| 1134 | | | | | # $value -> (optional) Value of the button when selected (also doubles as label). |
| 1135 | | | | | # $label -> (optional) Label printed on the button(also doubles as the value). |
| 1136 | | | | | # Returns: |
| 1137 | | | | | # A string containing a <input type="submit"> tag |
| 1138 | | | | | #### |
| 1139 | | | | | 'submit' => <<'END_OF_FUNC', |
| 1140 | | | | | sub submit { |
| 1141 | | | | | my($self,@p) = self_or_default(@_); |
| 1142 | | | | | |
| 1143 | | | | | my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p); |
| 1144 | | | | | |
| 1145 | | | | | $label=$self->_maybe_escapeHTML($label); |
| 1146 | | | | | $value=$self->_maybe_escapeHTML($value,1); |
| 1147 | | | | | |
| 1148 | | | | | my $name = $NOSTICKY ? '' : 'name=".submit" '; |
| 1149 | | | | | $name = qq/name="$label" / if defined($label); |
| 1150 | | | | | $value = defined($value) ? $value : $label; |
| 1151 | | | | | my $val = ''; |
| 1152 | | | | | $val = qq/value="$value" / if defined($value); |
| 1153 | | | | | $tabindex = $self->element_tab($tabindex); |
| 1154 | | | | | my($other) = @other ? "@other " : ''; |
| 1155 | | | | | return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>) |
| 1156 | | | | | : qq(<input type="submit" $name$val$other>); |
| 1157 | | | | | } |
| 1158 | | | | | END_OF_FUNC |
| 1159 | | | | | |
| 1160 | | | | | |
| 1161 | | | | | #### Method: reset |
| 1162 | | | | | # Create a "reset" button. |
| 1163 | | | | | # Parameters: |
| 1164 | | | | | # $name -> (optional) Name for the button. |
| 1165 | | | | | # Returns: |
| 1166 | | | | | # A string containing a <input type="reset"> tag |
| 1167 | | | | | #### |
| 1168 | | | | | 'reset' => <<'END_OF_FUNC', |
| 1169 | | | | | sub reset { |
| 1170 | | | | | my($self,@p) = self_or_default(@_); |
| 1171 | | | | | my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p); |
| 1172 | | | | | $label=$self->_maybe_escapeHTML($label); |
| 1173 | | | | | $value=$self->_maybe_escapeHTML($value,1); |
| 1174 | | | | | my ($name) = ' name=".reset"'; |
| 1175 | | | | | $name = qq/ name="$label"/ if defined($label); |
| 1176 | | | | | $value = defined($value) ? $value : $label; |
| 1177 | | | | | my($val) = ''; |
| 1178 | | | | | $val = qq/ value="$value"/ if defined($value); |
| 1179 | | | | | my($other) = @other ? " @other" : ''; |
| 1180 | | | | | $tabindex = $self->element_tab($tabindex); |
| 1181 | | | | | return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />) |
| 1182 | | | | | : qq(<input type="reset"$name$val$other>); |
| 1183 | | | | | } |
| 1184 | | | | | END_OF_FUNC |
| 1185 | | | | | |
| 1186 | | | | | |
| 1187 | | | | | #### Method: defaults |
| 1188 | | | | | # Create a "defaults" button. |
| 1189 | | | | | # Parameters: |
| 1190 | | | | | # $name -> (optional) Name for the button. |
| 1191 | | | | | # Returns: |
| 1192 | | | | | # A string containing a <input type="submit" name=".defaults"> tag |
| 1193 | | | | | # |
| 1194 | | | | | # Note: this button has a special meaning to the initialization script, |
| 1195 | | | | | # and tells it to ERASE the current query string so that your defaults |
| 1196 | | | | | # are used again! |
| 1197 | | | | | #### |
| 1198 | | | | | 'defaults' => <<'END_OF_FUNC', |
| 1199 | | | | | sub defaults { |
| 1200 | | | | | my($self,@p) = self_or_default(@_); |
| 1201 | | | | | |
| 1202 | | | | | my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p); |
| 1203 | | | | | |
| 1204 | | | | | $label=$self->_maybe_escapeHTML($label,1); |
| 1205 | | | | | $label = $label || "Defaults"; |
| 1206 | | | | | my($value) = qq/ value="$label"/; |
| 1207 | | | | | my($other) = @other ? " @other" : ''; |
| 1208 | | | | | $tabindex = $self->element_tab($tabindex); |
| 1209 | | | | | return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />) |
| 1210 | | | | | : qq/<input type="submit" NAME=".defaults"$value$other>/; |
| 1211 | | | | | } |
| 1212 | | | | | END_OF_FUNC |
| 1213 | | | | | |
| 1214 | | | | | |
| 1215 | | | | | #### Method: comment |
| 1216 | | | | | # Create an HTML <!-- comment --> |
| 1217 | | | | | # Parameters: a string |
| 1218 | | | | | 'comment' => <<'END_OF_FUNC', |
| 1219 | | | | | sub comment { |
| 1220 | | | | | my($self,@p) = self_or_CGI(@_); |
| 1221 | | | | | return "<!-- @p -->"; |
| 1222 | | | | | } |
| 1223 | | | | | END_OF_FUNC |
| 1224 | | | | | |
| 1225 | | | | | #### Method: checkbox |
| 1226 | | | | | # Create a checkbox that is not logically linked to any others. |
| 1227 | | | | | # The field value is "on" when the button is checked. |
| 1228 | | | | | # Parameters: |
| 1229 | | | | | # $name -> Name of the checkbox |
| 1230 | | | | | # $checked -> (optional) turned on by default if true |
| 1231 | | | | | # $value -> (optional) value of the checkbox, 'on' by default |
| 1232 | | | | | # $label -> (optional) a user-readable label printed next to the box. |
| 1233 | | | | | # Otherwise the checkbox name is used. |
| 1234 | | | | | # Returns: |
| 1235 | | | | | # A string containing a <input type="checkbox"> field |
| 1236 | | | | | #### |
| 1237 | | | | | 'checkbox' => <<'END_OF_FUNC', |
| 1238 | | | | | sub checkbox { |
| 1239 | | | | | my($self,@p) = self_or_default(@_); |
| 1240 | | | | | |
| 1241 | | | | | my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) = |
| 1242 | | | | | rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES, |
| 1243 | | | | | [OVERRIDE,FORCE],TABINDEX],@p); |
| 1244 | | | | | |
| 1245 | | | | | $value = defined $value ? $value : 'on'; |
| 1246 | | | | | |
| 1247 | | | | | if (!$override && ($self->{'.fieldnames'}->{$name} || |
| 1248 | | | | | defined $self->param($name))) { |
| 1249 | | | | | $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : ''; |
| 1250 | | | | | } else { |
| 1251 | | | | | $checked = $self->_checked($checked); |
| 1252 | | | | | } |
| 1253 | | | | | my($the_label) = defined $label ? $label : $name; |
| 1254 | | | | | $name = $self->_maybe_escapeHTML($name); |
| 1255 | | | | | $value = $self->_maybe_escapeHTML($value,1); |
| 1256 | | | | | $the_label = $self->_maybe_escapeHTML($the_label); |
| 1257 | | | | | my($other) = @other ? "@other " : ''; |
| 1258 | | | | | $tabindex = $self->element_tab($tabindex); |
| 1259 | | | | | $self->register_parameter($name); |
| 1260 | | | | | return $XHTML ? CGI::label($labelattributes, |
| 1261 | | | | | qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label}) |
| 1262 | | | | | : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label}; |
| 1263 | | | | | } |
| 1264 | | | | | END_OF_FUNC |
| 1265 | | | | | |
| - - | | | | | |
| 1268 | | | | | # Escape HTML |
| 1269 | | | | | 'escapeHTML' => <<'END_OF_FUNC', |
| 1270 | | | | | sub escapeHTML { |
| 1271 | | | | | # hack to work around earlier hacks |
| 1272 | | | | | push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; |
| 1273 | | | | | my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_); |
| 1274 | | | | | return undef unless defined($toencode); |
| 1275 | | | | | $toencode =~ s{&}{&}gso; |
| 1276 | | | | | $toencode =~ s{<}{<}gso; |
| 1277 | | | | | $toencode =~ s{>}{>}gso; |
| 1278 | | | | | if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) { |
| 1279 | | | | | # $quot; was accidentally omitted from the HTML 3.2 DTD -- see |
| 1280 | | | | | # <http://validator.w3.org/docs/errors.html#bad-entity> / |
| 1281 | | | | | # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>. |
| 1282 | | | | | $toencode =~ s{"}{"}gso; |
| 1283 | | | | | } |
| 1284 | | | | | else { |
| 1285 | | | | | $toencode =~ s{"}{"}gso; |
| 1286 | | | | | } |
| 1287 | | | | | |
| 1288 | | | | | # Handle bug in some browsers with Latin charsets |
| 1289 | | | | | if ($self->{'.charset'} |
| 1290 | | | | | && (uc($self->{'.charset'}) eq 'ISO-8859-1' |
| 1291 | | | | | || uc($self->{'.charset'}) eq 'WINDOWS-1252')) { |
| 1292 | | | | | $toencode =~ s{'}{'}gso; |
| 1293 | | | | | $toencode =~ s{\x8b}{‹}gso; |
| 1294 | | | | | $toencode =~ s{\x9b}{›}gso; |
| 1295 | | | | | if (defined $newlinestoo && $newlinestoo) { |
| 1296 | | | | | $toencode =~ s{\012}{ }gso; |
| 1297 | | | | | $toencode =~ s{\015}{ }gso; |
| 1298 | | | | | } |
| 1299 | | | | | } |
| 1300 | | | | | return $toencode; |
| 1301 | | | | | } |
| 1302 | | | | | END_OF_FUNC |
| 1303 | | | | | |
| 1304 | | | | | # unescape HTML -- used internally |
| 1305 | | | | | 'unescapeHTML' => <<'END_OF_FUNC', |
| 1306 | | | | | sub unescapeHTML { |
| 1307 | | | | | # hack to work around earlier hacks |
| 1308 | | | | | push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; |
| 1309 | | | | | my ($self,$string) = CGI::self_or_default(@_); |
| 1310 | | | | | return undef unless defined($string); |
| 1311 | | | | | my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i |
| 1312 | | | | | : 1; |
| 1313 | | | | | # thanks to Randal Schwartz for the correct solution to this one |
| 1314 | | | | | $string=~ s[&([^\s&]*?);]{ |
| 1315 | | | | | local $_ = $1; |
| 1316 | | | | | /^amp$/i ? "&" : |
| 1317 | | | | | /^quot$/i ? '"' : |
| 1318 | | | | | /^gt$/i ? ">" : |
| 1319 | | | | | /^lt$/i ? "<" : |
| 1320 | | | | | /^#(\d+)$/ && $latin ? chr($1) : |
| 1321 | | | | | /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) : |
| 1322 | | | | | "&$_;" |
| 1323 | | | | | }gex; |
| 1324 | | | | | return $string; |
| 1325 | | | | | } |
| 1326 | | | | | END_OF_FUNC |
| 1327 | | | | | |
| 1328 | | | | | # Internal procedure - don't use |
| 1329 | | | | | '_tableize' => <<'END_OF_FUNC', |
| 1330 | | | | | sub _tableize { |
| 1331 | | | | | my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; |
| 1332 | | | | | my @rowheaders = $rowheaders ? @$rowheaders : (); |
| 1333 | | | | | my @colheaders = $colheaders ? @$colheaders : (); |
| 1334 | | | | | my($result); |
| 1335 | | | | | |
| 1336 | | | | | if (defined($columns)) { |
| 1337 | | | | | $rows = int(0.99 + @elements/$columns) unless defined($rows); |
| 1338 | | | | | } |
| 1339 | | | | | if (defined($rows)) { |
| 1340 | | | | | $columns = int(0.99 + @elements/$rows) unless defined($columns); |
| 1341 | | | | | } |
| 1342 | | | | | |
| 1343 | | | | | # rearrange into a pretty table |
| 1344 | | | | | $result = "<table>"; |
| 1345 | | | | | my($row,$column); |
| 1346 | | | | | unshift(@colheaders,'') if @colheaders && @rowheaders; |
| 1347 | | | | | $result .= "<tr>" if @colheaders; |
| 1348 | | | | | for (@colheaders) { |
| 1349 | | | | | $result .= "<th>$_</th>"; |
| 1350 | | | | | } |
| 1351 | | | | | for ($row=0;$row<$rows;$row++) { |
| 1352 | | | | | $result .= "<tr>"; |
| 1353 | | | | | $result .= "<th>$rowheaders[$row]</th>" if @rowheaders; |
| 1354 | | | | | for ($column=0;$column<$columns;$column++) { |
| 1355 | | | | | $result .= "<td>" . $elements[$column*$rows + $row] . "</td>" |
| 1356 | | | | | if defined($elements[$column*$rows + $row]); |
| 1357 | | | | | } |
| 1358 | | | | | $result .= "</tr>"; |
| 1359 | | | | | } |
| 1360 | | | | | $result .= "</table>"; |
| 1361 | | | | | return $result; |
| 1362 | | | | | } |
| 1363 | | | | | END_OF_FUNC |
| 1364 | | | | | |
| 1365 | | | | | |
| 1366 | | | | | #### Method: radio_group |
| 1367 | | | | | # Create a list of logically-linked radio buttons. |
| 1368 | | | | | # Parameters: |
| 1369 | | | | | # $name -> Common name for all the buttons. |
| 1370 | | | | | # $values -> A pointer to a regular array containing the |
| 1371 | | | | | # values for each button in the group. |
| 1372 | | | | | # $default -> (optional) Value of the button to turn on by default. Pass '-' |
| 1373 | | | | | # to turn _nothing_ on. |
| 1374 | | | | | # $linebreak -> (optional) Set to true to place linebreaks |
| 1375 | | | | | # between the buttons. |
| 1376 | | | | | # $labels -> (optional) |
| 1377 | | | | | # A pointer to a hash of labels to print next to each checkbox |
| 1378 | | | | | # in the form $label{'value'}="Long explanatory label". |
| 1379 | | | | | # Otherwise the provided values are used as the labels. |
| 1380 | | | | | # Returns: |
| 1381 | | | | | # An ARRAY containing a series of <input type="radio"> fields |
| 1382 | | | | | #### |
| 1383 | | | | | 'radio_group' => <<'END_OF_FUNC', |
| 1384 | | | | | sub radio_group { |
| 1385 | | | | | my($self,@p) = self_or_default(@_); |
| 1386 | | | | | $self->_box_group('radio',@p); |
| 1387 | | | | | } |
| 1388 | | | | | END_OF_FUNC |
| 1389 | | | | | |
| 1390 | | | | | #### Method: checkbox_group |
| 1391 | | | | | # Create a list of logically-linked checkboxes. |
| 1392 | | | | | # Parameters: |
| 1393 | | | | | # $name -> Common name for all the check boxes |
| 1394 | | | | | # $values -> A pointer to a regular array containing the |
| 1395 | | | | | # values for each checkbox in the group. |
| 1396 | | | | | # $defaults -> (optional) |
| 1397 | | | | | # 1. If a pointer to a regular array of checkbox values, |
| 1398 | | | | | # then this will be used to decide which |
| 1399 | | | | | # checkboxes to turn on by default. |
| 1400 | | | | | # 2. If a scalar, will be assumed to hold the |
| 1401 | | | | | # value of a single checkbox in the group to turn on. |
| 1402 | | | | | # $linebreak -> (optional) Set to true to place linebreaks |
| 1403 | | | | | # between the buttons. |
| 1404 | | | | | # $labels -> (optional) |
| 1405 | | | | | # A pointer to a hash of labels to print next to each checkbox |
| 1406 | | | | | # in the form $label{'value'}="Long explanatory label". |
| 1407 | | | | | # Otherwise the provided values are used as the labels. |
| 1408 | | | | | # Returns: |
| 1409 | | | | | # An ARRAY containing a series of <input type="checkbox"> fields |
| 1410 | | | | | #### |
| 1411 | | | | | |
| 1412 | | | | | 'checkbox_group' => <<'END_OF_FUNC', |
| 1413 | | | | | sub checkbox_group { |
| 1414 | | | | | my($self,@p) = self_or_default(@_); |
| 1415 | | | | | $self->_box_group('checkbox',@p); |
| 1416 | | | | | } |
| 1417 | | | | | END_OF_FUNC |
| 1418 | | | | | |
| 1419 | | | | | '_box_group' => <<'END_OF_FUNC', |
| 1420 | | | | | sub _box_group { |
| 1421 | | | | | my $self = shift; |
| 1422 | | | | | my $box_type = shift; |
| 1423 | | | | | |
| 1424 | | | | | my($name,$values,$defaults,$linebreak,$labels,$labelattributes, |
| 1425 | | | | | $attributes,$rows,$columns,$rowheaders,$colheaders, |
| 1426 | | | | | $override,$nolabels,$tabindex,$disabled,@other) = |
| 1427 | | | | | rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES, |
| 1428 | | | | | ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER], |
| 1429 | | | | | [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED |
| 1430 | | | | | ],@_); |
| 1431 | | | | | |
| 1432 | | | | | |
| 1433 | | | | | my($result,$checked,@elements,@values); |
| 1434 | | | | | |
| 1435 | | | | | @values = $self->_set_values_and_labels($values,\$labels,$name); |
| 1436 | | | | | my %checked = $self->previous_or_default($name,$defaults,$override); |
| 1437 | | | | | |
| 1438 | | | | | # If no check array is specified, check the first by default |
| 1439 | | | | | $checked{$values[0]}++ if $box_type eq 'radio' && !%checked; |
| 1440 | | | | | |
| 1441 | | | | | $name=$self->_maybe_escapeHTML($name); |
| 1442 | | | | | |
| 1443 | | | | | my %tabs = (); |
| 1444 | | | | | if ($TABINDEX && $tabindex) { |
| 1445 | | | | | if (!ref $tabindex) { |
| 1446 | | | | | $self->element_tab($tabindex); |
| 1447 | | | | | } elsif (ref $tabindex eq 'ARRAY') { |
| 1448 | | | | | %tabs = map {$_=>$self->element_tab} @$tabindex; |
| 1449 | | | | | } elsif (ref $tabindex eq 'HASH') { |
| 1450 | | | | | %tabs = %$tabindex; |
| 1451 | | | | | } |
| 1452 | | | | | } |
| 1453 | | | | | %tabs = map {$_=>$self->element_tab} @values unless %tabs; |
| 1454 | | | | | my $other = @other ? "@other " : ''; |
| 1455 | | | | | my $radio_checked; |
| 1456 | | | | | |
| 1457 | | | | | # for disabling groups of radio/checkbox buttons |
| 1458 | | | | | my %disabled; |
| 1459 | | | | | for (@{$disabled}) { |
| 1460 | | | | | $disabled{$_}=1; |
| 1461 | | | | | } |
| 1462 | | | | | |
| 1463 | | | | | for (@values) { |
| 1464 | | | | | my $disable=""; |
| 1465 | | | | | if ($disabled{$_}) { |
| 1466 | | | | | $disable="disabled='1'"; |
| 1467 | | | | | } |
| 1468 | | | | | |
| 1469 | | | | | my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++) |
| 1470 | | | | | : $checked{$_}); |
| 1471 | | | | | my($break); |
| 1472 | | | | | if ($linebreak) { |
| 1473 | | | | | $break = $XHTML ? "<br />" : "<br>"; |
| 1474 | | | | | } |
| 1475 | | | | | else { |
| 1476 | | | | | $break = ''; |
| 1477 | | | | | } |
| 1478 | | | | | my($label)=''; |
| 1479 | | | | | unless (defined($nolabels) && $nolabels) { |
| 1480 | | | | | $label = $_; |
| 1481 | | | | | $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); |
| 1482 | | | | | $label = $self->_maybe_escapeHTML($label,1); |
| 1483 | | | | | $label = "<span style=\"color:gray\">$label</span>" if $disabled{$_}; |
| 1484 | | | | | } |
| 1485 | | | | | my $attribs = $self->_set_attributes($_, $attributes); |
| 1486 | | | | | my $tab = $tabs{$_}; |
| 1487 | | | | | $_=$self->_maybe_escapeHTML($_); |
| 1488 | | | | | |
| 1489 | | | | | if ($XHTML) { |
| 1490 | | | | | push @elements, |
| 1491 | | | | | CGI::label($labelattributes, |
| 1492 | | | | | qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break}; |
| 1493 | | | | | } else { |
| 1494 | | | | | push(@elements,qq/<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable>${label}${break}/); |
| 1495 | | | | | } |
| 1496 | | | | | } |
| 1497 | | | | | $self->register_parameter($name); |
| 1498 | | | | | return wantarray ? @elements : "@elements" |
| 1499 | | | | | unless defined($columns) || defined($rows); |
| 1500 | | | | | return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); |
| 1501 | | | | | } |
| 1502 | | | | | END_OF_FUNC |
| 1503 | | | | | |
| 1504 | | | | | |
| 1505 | | | | | #### Method: popup_menu |
| 1506 | | | | | # Create a popup menu. |
| 1507 | | | | | # Parameters: |
| 1508 | | | | | # $name -> Name for all the menu |
| 1509 | | | | | # $values -> A pointer to a regular array containing the |
| 1510 | | | | | # text of each menu item. |
| 1511 | | | | | # $default -> (optional) Default item to display |
| 1512 | | | | | # $labels -> (optional) |
| 1513 | | | | | # A pointer to a hash of labels to print next to each checkbox |
| 1514 | | | | | # in the form $label{'value'}="Long explanatory label". |
| 1515 | | | | | # Otherwise the provided values are used as the labels. |
| 1516 | | | | | # Returns: |
| 1517 | | | | | # A string containing the definition of a popup menu. |
| 1518 | | | | | #### |
| 1519 | | | | | 'popup_menu' => <<'END_OF_FUNC', |
| 1520 | | | | | sub popup_menu { |
| 1521 | | | | | my($self,@p) = self_or_default(@_); |
| 1522 | | | | | |
| 1523 | | | | | my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) = |
| 1524 | | | | | rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS, |
| 1525 | | | | | ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); |
| 1526 | | | | | my($result,%selected); |
| 1527 | | | | | |
| 1528 | | | | | if (!$override && defined($self->param($name))) { |
| 1529 | | | | | $selected{$self->param($name)}++; |
| 1530 | | | | | } elsif (defined $default) { |
| 1531 | | | | | %selected = map {$_=>1} ref($default) eq 'ARRAY' |
| 1532 | | | | | ? @$default |
| 1533 | | | | | : $default; |
| 1534 | | | | | } |
| 1535 | | | | | $name=$self->_maybe_escapeHTML($name); |
| 1536 | | | | | # RT #30057 - ignore -multiple, if you need this |
| 1537 | | | | | # then use scrolling_list |
| 1538 | | | | | @other = grep { $_ !~ /^multiple=/i } @other; |
| 1539 | | | | | my($other) = @other ? " @other" : ''; |
| 1540 | | | | | |
| 1541 | | | | | my(@values); |
| 1542 | | | | | @values = $self->_set_values_and_labels($values,\$labels,$name); |
| 1543 | | | | | $tabindex = $self->element_tab($tabindex); |
| 1544 | | | | | $name = q{} if ! defined $name; |
| 1545 | | | | | $result = qq/<select name="$name" $tabindex$other>\n/; |
| 1546 | | | | | for (@values) { |
| 1547 | | | | | if (/<optgroup/) { |
| 1548 | | | | | for my $v (split(/\n/)) { |
| 1549 | | | | | my $selectit = $XHTML ? 'selected="selected"' : 'selected'; |
| 1550 | | | | | for my $selected (keys %selected) { |
| 1551 | | | | | $v =~ s/(value="\Q$selected\E")/$selectit $1/; |
| 1552 | | | | | } |
| 1553 | | | | | $result .= "$v\n"; |
| 1554 | | | | | } |
| 1555 | | | | | } |
| 1556 | | | | | else { |
| 1557 | | | | | my $attribs = $self->_set_attributes($_, $attributes); |
| 1558 | | | | | my($selectit) = $self->_selected($selected{$_}); |
| 1559 | | | | | my($label) = $_; |
| 1560 | | | | | $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); |
| 1561 | | | | | my($value) = $self->_maybe_escapeHTML($_); |
| 1562 | | | | | $label = $self->_maybe_escapeHTML($label,1); |
| 1563 | | | | | $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n"; |
| 1564 | | | | | } |
| 1565 | | | | | } |
| 1566 | | | | | |
| 1567 | | | | | $result .= "</select>"; |
| 1568 | | | | | return $result; |
| 1569 | | | | | } |
| 1570 | | | | | END_OF_FUNC |
| 1571 | | | | | |
| 1572 | | | | | |
| 1573 | | | | | #### Method: optgroup |
| 1574 | | | | | # Create a optgroup. |
| 1575 | | | | | # Parameters: |
| 1576 | | | | | # $name -> Label for the group |
| 1577 | | | | | # $values -> A pointer to a regular array containing the |
| 1578 | | | | | # values for each option line in the group. |
| 1579 | | | | | # $labels -> (optional) |
| 1580 | | | | | # A pointer to a hash of labels to print next to each item |
| 1581 | | | | | # in the form $label{'value'}="Long explanatory label". |
| 1582 | | | | | # Otherwise the provided values are used as the labels. |
| 1583 | | | | | # $labeled -> (optional) |
| 1584 | | | | | # A true value indicates the value should be used as the label attribute |
| 1585 | | | | | # in the option elements. |
| 1586 | | | | | # The label attribute specifies the option label presented to the user. |
| 1587 | | | | | # This defaults to the content of the <option> element, but the label |
| 1588 | | | | | # attribute allows authors to more easily use optgroup without sacrificing |
| 1589 | | | | | # compatibility with browsers that do not support option groups. |
| 1590 | | | | | # $novals -> (optional) |
| 1591 | | | | | # A true value indicates to suppress the val attribute in the option elements |
| 1592 | | | | | # Returns: |
| 1593 | | | | | # A string containing the definition of an option group. |
| 1594 | | | | | #### |
| 1595 | | | | | 'optgroup' => <<'END_OF_FUNC', |
| 1596 | | | | | sub optgroup { |
| 1597 | | | | | my($self,@p) = self_or_default(@_); |
| 1598 | | | | | my($name,$values,$attributes,$labeled,$noval,$labels,@other) |
| 1599 | | | | | = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p); |
| 1600 | | | | | |
| 1601 | | | | | my($result,@values); |
| 1602 | | | | | @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals); |
| 1603 | | | | | my($other) = @other ? " @other" : ''; |
| 1604 | | | | | |
| 1605 | | | | | $name = $self->_maybe_escapeHTML($name) || q{}; |
| 1606 | | | | | $result = qq/<optgroup label="$name"$other>\n/; |
| 1607 | | | | | for (@values) { |
| 1608 | | | | | if (/<optgroup/) { |
| 1609 | | | | | for (split(/\n/)) { |
| 1610 | | | | | my $selectit = $XHTML ? 'selected="selected"' : 'selected'; |
| 1611 | | | | | s/(value="$selected")/$selectit $1/ if defined $selected; |
| 1612 | | | | | $result .= "$_\n"; |
| 1613 | | | | | } |
| 1614 | | | | | } |
| 1615 | | | | | else { |
| 1616 | | | | | my $attribs = $self->_set_attributes($_, $attributes); |
| 1617 | | | | | my($label) = $_; |
| 1618 | | | | | $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); |
| 1619 | | | | | $label=$self->_maybe_escapeHTML($label); |
| 1620 | | | | | my($value)=$self->_maybe_escapeHTML($_,1); |
| 1621 | | | | | $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n" |
| 1622 | | | | | : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n" |
| 1623 | | | | | : $novals ? "<option$attribs>$label</option>\n" |
| 1624 | | | | | : "<option$attribs value=\"$value\">$label</option>\n"; |
| 1625 | | | | | } |
| 1626 | | | | | } |
| 1627 | | | | | $result .= "</optgroup>"; |
| 1628 | | | | | return $result; |
| 1629 | | | | | } |
| 1630 | | | | | END_OF_FUNC |
| 1631 | | | | | |
| 1632 | | | | | |
| 1633 | | | | | #### Method: scrolling_list |
| 1634 | | | | | # Create a scrolling list. |
| 1635 | | | | | # Parameters: |
| 1636 | | | | | # $name -> name for the list |
| 1637 | | | | | # $values -> A pointer to a regular array containing the |
| 1638 | | | | | # values for each option line in the list. |
| 1639 | | | | | # $defaults -> (optional) |
| 1640 | | | | | # 1. If a pointer to a regular array of options, |
| 1641 | | | | | # then this will be used to decide which |
| 1642 | | | | | # lines to turn on by default. |
| 1643 | | | | | # 2. Otherwise holds the value of the single line to turn on. |
| 1644 | | | | | # $size -> (optional) Size of the list. |
| 1645 | | | | | # $multiple -> (optional) If set, allow multiple selections. |
| 1646 | | | | | # $labels -> (optional) |
| 1647 | | | | | # A pointer to a hash of labels to print next to each checkbox |
| 1648 | | | | | # in the form $label{'value'}="Long explanatory label". |
| 1649 | | | | | # Otherwise the provided values are used as the labels. |
| 1650 | | | | | # Returns: |
| 1651 | | | | | # A string containing the definition of a scrolling list. |
| 1652 | | | | | #### |
| 1653 | | | | | 'scrolling_list' => <<'END_OF_FUNC', |
| 1654 | | | | | sub scrolling_list { |
| 1655 | | | | | my($self,@p) = self_or_default(@_); |
| 1656 | | | | | my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other) |
| 1657 | | | | | = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], |
| 1658 | | | | | SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); |
| 1659 | | | | | |
| 1660 | | | | | my($result,@values); |
| 1661 | | | | | @values = $self->_set_values_and_labels($values,\$labels,$name); |
| 1662 | | | | | |
| 1663 | | | | | $size = $size || scalar(@values); |
| 1664 | | | | | |
| 1665 | | | | | my(%selected) = $self->previous_or_default($name,$defaults,$override); |
| 1666 | | | | | |
| 1667 | | | | | my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : ''; |
| 1668 | | | | | my($has_size) = $size ? qq/ size="$size"/: ''; |
| 1669 | | | | | my($other) = @other ? " @other" : ''; |
| 1670 | | | | | |
| 1671 | | | | | $name=$self->_maybe_escapeHTML($name); |
| 1672 | | | | | $tabindex = $self->element_tab($tabindex); |
| 1673 | | | | | $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/; |
| 1674 | | | | | for (@values) { |
| 1675 | | | | | if (/<optgroup/) { |
| 1676 | | | | | for my $v (split(/\n/)) { |
| 1677 | | | | | my $selectit = $XHTML ? 'selected="selected"' : 'selected'; |
| 1678 | | | | | for my $selected (keys %selected) { |
| 1679 | | | | | $v =~ s/(value="$selected")/$selectit $1/; |
| 1680 | | | | | } |
| 1681 | | | | | $result .= "$v\n"; |
| 1682 | | | | | } |
| 1683 | | | | | } |
| 1684 | | | | | else { |
| 1685 | | | | | my $attribs = $self->_set_attributes($_, $attributes); |
| 1686 | | | | | my($selectit) = $self->_selected($selected{$_}); |
| 1687 | | | | | my($label) = $_; |
| 1688 | | | | | $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); |
| 1689 | | | | | my($value) = $self->_maybe_escapeHTML($_); |
| 1690 | | | | | $label = $self->_maybe_escapeHTML($label,1); |
| 1691 | | | | | $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n"; |
| 1692 | | | | | } |
| 1693 | | | | | } |
| 1694 | | | | | |
| 1695 | | | | | $result .= "</select>"; |
| 1696 | | | | | $self->register_parameter($name); |
| 1697 | | | | | return $result; |
| 1698 | | | | | } |
| 1699 | | | | | END_OF_FUNC |
| 1700 | | | | | |
| 1701 | | | | | |
| 1702 | | | | | #### Method: hidden |
| 1703 | | | | | # Parameters: |
| 1704 | | | | | # $name -> Name of the hidden field |
| 1705 | | | | | # @default -> (optional) Initial values of field (may be an array) |
| 1706 | | | | | # or |
| 1707 | | | | | # $default->[initial values of field] |
| 1708 | | | | | # Returns: |
| 1709 | | | | | # A string containing a <input type="hidden" name="name" value="value"> |
| 1710 | | | | | #### |
| 1711 | | | | | 'hidden' => <<'END_OF_FUNC', |
| 1712 | | | | | sub hidden { |
| 1713 | | | | | my($self,@p) = self_or_default(@_); |
| 1714 | | | | | |
| 1715 | | | | | # this is the one place where we departed from our standard |
| 1716 | | | | | # calling scheme, so we have to special-case (darn) |
| 1717 | | | | | my(@result,@value); |
| 1718 | | | | | my($name,$default,$override,@other) = |
| 1719 | | | | | rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); |
| 1720 | | | | | |
| 1721 | | | | | my $do_override = 0; |
| 1722 | | | | | if ( ref($p[0]) || substr($p[0],0,1) eq '-') { |
| 1723 | | | | | @value = ref($default) ? @{$default} : $default; |
| 1724 | | | | | $do_override = $override; |
| 1725 | | | | | } else { |
| 1726 | | | | | for ($default,$override,@other) { |
| 1727 | | | | | push(@value,$_) if defined($_); |
| 1728 | | | | | } |
| 1729 | | | | | undef @other; |
| 1730 | | | | | } |
| 1731 | | | | | |
| 1732 | | | | | # use previous values if override is not set |
| 1733 | | | | | my @prev = $self->param($name); |
| 1734 | | | | | @value = @prev if !$do_override && @prev; |
| 1735 | | | | | |
| 1736 | | | | | $name=$self->_maybe_escapeHTML($name); |
| 1737 | | | | | for (@value) { |
| 1738 | | | | | $_ = defined($_) ? $self->_maybe_escapeHTML($_,1) : ''; |
| 1739 | | | | | push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />) |
| 1740 | | | | | : qq(<input type="hidden" name="$name" value="$_" @other>); |
| 1741 | | | | | } |
| 1742 | | | | | return wantarray ? @result : join('',@result); |
| 1743 | | | | | } |
| 1744 | | | | | END_OF_FUNC |
| 1745 | | | | | |
| 1746 | | | | | |
| 1747 | | | | | #### Method: image_button |
| 1748 | | | | | # Parameters: |
| 1749 | | | | | # $name -> Name of the button |
| 1750 | | | | | # $src -> URL of the image source |
| 1751 | | | | | # $align -> Alignment style (TOP, BOTTOM or MIDDLE) |
| 1752 | | | | | # Returns: |
| 1753 | | | | | # A string containing a <input type="image" name="name" src="url" align="alignment"> |
| 1754 | | | | | #### |
| 1755 | | | | | 'image_button' => <<'END_OF_FUNC', |
| 1756 | | | | | sub image_button { |
| 1757 | | | | | my($self,@p) = self_or_default(@_); |
| 1758 | | | | | |
| 1759 | | | | | my($name,$src,$alignment,@other) = |
| 1760 | | | | | rearrange([NAME,SRC,ALIGN],@p); |
| 1761 | | | | | |
| 1762 | | | | | my($align) = $alignment ? " align=\L\"$alignment\"" : ''; |
| 1763 | | | | | my($other) = @other ? " @other" : ''; |
| 1764 | | | | | $name=$self->_maybe_escapeHTML($name); |
| 1765 | | | | | return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />) |
| 1766 | | | | | : qq/<input type="image" name="$name" src="$src"$align$other>/; |
| 1767 | | | | | } |
| 1768 | | | | | END_OF_FUNC |
| 1769 | | | | | |
| 1770 | | | | | |
| 1771 | | | | | #### Method: self_url |
| 1772 | | | | | # Returns a URL containing the current script and all its |
| 1773 | | | | | # param/value pairs arranged as a query. You can use this |
| 1774 | | | | | # to create a link that, when selected, will reinvoke the |
| 1775 | | | | | # script with all its state information preserved. |
| 1776 | | | | | #### |
| 1777 | | | | | 'self_url' => <<'END_OF_FUNC', |
| 1778 | | | | | sub self_url { |
| 1779 | | | | | my($self,@p) = self_or_default(@_); |
| 1780 | | | | | return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p); |
| 1781 | | | | | } |
| 1782 | | | | | END_OF_FUNC |
| 1783 | | | | | |
| 1784 | | | | | |
| 1785 | | | | | # This is provided as a synonym to self_url() for people unfortunate |
| 1786 | | | | | # enough to have incorporated it into their programs already! |
| 1787 | | | | | 'state' => <<'END_OF_FUNC', |
| 1788 | | | | | sub state { |
| 1789 | | | | | &self_url; |
| 1790 | | | | | } |
| 1791 | | | | | END_OF_FUNC |
| 1792 | | | | | |
| 1793 | | | | | |
| 1794 | | | | | #### Method: url |
| 1795 | | | | | # Like self_url, but doesn't return the query string part of |
| 1796 | | | | | # the URL. |
| 1797 | | | | | #### |
| 1798 | | | | | 'url' => <<'END_OF_FUNC', |
| 1799 | | | | | sub url { |
| 1800 | | | | | my($self,@p) = self_or_default(@_); |
| 1801 | | | | | my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) = |
| 1802 | | | | | rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p); |
| 1803 | | | | | my $url = ''; |
| 1804 | | | | | $full++ if $base || !($relative || $absolute); |
| 1805 | | | | | $rewrite++ unless defined $rewrite; |
| 1806 | | | | | |
| 1807 | | | | | my $path = $self->path_info; |
| 1808 | | | | | my $script_name = $self->script_name; |
| 1809 | | | | | my $request_uri = $self->request_uri || ''; |
| 1810 | | | | | my $query_str = $query ? $self->query_string : ''; |
| 1811 | | | | | |
| 1812 | | | | | $request_uri =~ s/\?.*$//s; # remove query string |
| 1813 | | | | | $request_uri = unescape($request_uri); |
| 1814 | | | | | |
| 1815 | | | | | my $uri = $rewrite && $request_uri ? $request_uri : $script_name; |
| 1816 | | | | | $uri =~ s/\?.*$//s; # remove query string |
| 1817 | | | | | |
| 1818 | | | | | if ( defined( $ENV{PATH_INFO} ) ) { |
| 1819 | | | | | # IIS sometimes sets PATH_INFO to the same value as SCRIPT_NAME so only sub it out |
| 1820 | | | | | # if SCRIPT_NAME isn't defined or isn't the same value as PATH_INFO |
| 1821 | | | | | $uri =~ s/\Q$ENV{PATH_INFO}\E$// |
| 1822 | | | | | if ( ! defined( $ENV{SCRIPT_NAME} ) or $ENV{PATH_INFO} ne $ENV{SCRIPT_NAME} ); |
| 1823 | | | | | } |
| 1824 | | | | | |
| 1825 | | | | | if ($full) { |
| 1826 | | | | | my $protocol = $self->protocol(); |
| 1827 | | | | | $url = "$protocol://"; |
| 1828 | | | | | my $vh = http('x_forwarded_host') || http('host') || ''; |
| 1829 | | | | | $vh =~ s/^.*,\s*//; # x_forwarded_host may be a comma-separated list (e.g. when the request has |
| 1830 | | | | | # passed through multiple reverse proxies. Take the last one. |
| 1831 | | | | | $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it. |
| 1832 | | | | | |
| 1833 | | | | | $url .= $vh || server_name(); |
| 1834 | | | | | |
| 1835 | | | | | my $port = $self->virtual_port; |
| 1836 | | | | | |
| 1837 | | | | | # add the port to the url unless it's the protocol's default port |
| 1838 | | | | | $url .= ':' . $port unless (lc($protocol) eq 'http' && $port == 80) |
| 1839 | | | | | or (lc($protocol) eq 'https' && $port == 443); |
| 1840 | | | | | |
| 1841 | | | | | return $url if $base; |
| 1842 | | | | | |
| 1843 | | | | | $url .= $uri; |
| 1844 | | | | | } elsif ($relative) { |
| 1845 | | | | | ($url) = $uri =~ m!([^/]+)$!; |
| 1846 | | | | | } elsif ($absolute) { |
| 1847 | | | | | $url = $uri; |
| 1848 | | | | | } |
| 1849 | | | | | |
| 1850 | | | | | $url .= $path if $path_info and defined $path; |
| 1851 | | | | | $url .= "?$query_str" if $query and $query_str ne ''; |
| 1852 | | | | | $url ||= ''; |
| 1853 | | | | | $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg; |
| 1854 | | | | | return $url; |
| 1855 | | | | | } |
| 1856 | | | | | |
| 1857 | | | | | END_OF_FUNC |
| 1858 | | | | | |
| 1859 | | | | | #### Method: cookie |
| 1860 | | | | | # Set or read a cookie from the specified name. |
| 1861 | | | | | # Cookie can then be passed to header(). |
| 1862 | | | | | # Usual rules apply to the stickiness of -value. |
| 1863 | | | | | # Parameters: |
| 1864 | | | | | # -name -> name for this cookie (optional) |
| 1865 | | | | | # -value -> value of this cookie (scalar, array or hash) |
| 1866 | | | | | # -path -> paths for which this cookie is valid (optional) |
| 1867 | | | | | # -domain -> internet domain in which this cookie is valid (optional) |
| 1868 | | | | | # -secure -> if true, cookie only passed through secure channel (optional) |
| 1869 | | | | | # -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional) |
| 1870 | | | | | #### |
| 1871 | | | | | 'cookie' => <<'END_OF_FUNC', |
| 1872 | | | | | sub cookie { |
| 1873 | | | | | my($self,@p) = self_or_default(@_); |
| 1874 | | | | | my($name,$value,$path,$domain,$secure,$expires,$httponly) = |
| 1875 | | | | | rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p); |
| 1876 | | | | | |
| 1877 | | | | | require CGI::Cookie; |
| 1878 | | | | | |
| 1879 | | | | | # if no value is supplied, then we retrieve the |
| 1880 | | | | | # value of the cookie, if any. For efficiency, we cache the parsed |
| 1881 | | | | | # cookies in our state variables. |
| 1882 | | | | | unless ( defined($value) ) { |
| 1883 | | | | | $self->{'.cookies'} = CGI::Cookie->fetch; |
| 1884 | | | | | |
| 1885 | | | | | # If no name is supplied, then retrieve the names of all our cookies. |
| 1886 | | | | | return () unless $self->{'.cookies'}; |
| 1887 | | | | | return keys %{$self->{'.cookies'}} unless $name; |
| 1888 | | | | | return () unless $self->{'.cookies'}->{$name}; |
| 1889 | | | | | return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne ''; |
| 1890 | | | | | } |
| 1891 | | | | | |
| 1892 | | | | | # If we get here, we're creating a new cookie |
| 1893 | | | | | return undef unless defined($name) && $name ne ''; # this is an error |
| 1894 | | | | | |
| 1895 | | | | | my @param; |
| 1896 | | | | | push(@param,'-name'=>$name); |
| 1897 | | | | | push(@param,'-value'=>$value); |
| 1898 | | | | | push(@param,'-domain'=>$domain) if $domain; |
| 1899 | | | | | push(@param,'-path'=>$path) if $path; |
| 1900 | | | | | push(@param,'-expires'=>$expires) if $expires; |
| 1901 | | | | | push(@param,'-secure'=>$secure) if $secure; |
| 1902 | | | | | push(@param,'-httponly'=>$httponly) if $httponly; |
| 1903 | | | | | |
| 1904 | | | | | return CGI::Cookie->new(@param); |
| 1905 | | | | | } |
| 1906 | | | | | END_OF_FUNC |
| 1907 | | | | | |
| 1908 | | | | | 'parse_keywordlist' => <<'END_OF_FUNC', |
| 1909 | | | | | sub parse_keywordlist { |
| 1910 | | | | | my($self,$tosplit) = @_; |
| 1911 | | | | | $tosplit = unescape($tosplit); # unescape the keywords |
| 1912 | | | | | $tosplit=~tr/+/ /; # pluses to spaces |
| 1913 | | | | | my(@keywords) = split(/\s+/,$tosplit); |
| 1914 | | | | | return @keywords; |
| 1915 | | | | | } |
| 1916 | | | | | END_OF_FUNC |
| 1917 | | | | | |
| 1918 | | | | | 'param_fetch' => <<'END_OF_FUNC', |
| 1919 | | | | | sub param_fetch { |
| 1920 | | | | | my($self,@p) = self_or_default(@_); |
| 1921 | | | | | my($name) = rearrange([NAME],@p); |
| 1922 | | | | | return [] unless defined $name; |
| 1923 | | | | | |
| 1924 | | | | | unless (exists($self->{param}{$name})) { |
| 1925 | | | | | $self->add_parameter($name); |
| 1926 | | | | | $self->{param}{$name} = []; |
| 1927 | | | | | } |
| 1928 | | | | | |
| 1929 | | | | | return $self->{param}{$name}; |
| 1930 | | | | | } |
| 1931 | | | | | END_OF_FUNC |
| 1932 | | | | | |
| 1933 | | | | | ############################################### |
| 1934 | | | | | # OTHER INFORMATION PROVIDED BY THE ENVIRONMENT |
| 1935 | | | | | ############################################### |
| 1936 | | | | | |
| 1937 | | | | | #### Method: path_info |
| 1938 | | | | | # Return the extra virtual path information provided |
| 1939 | | | | | # after the URL (if any) |
| 1940 | | | | | #### |
| 1941 | | | | | 'path_info' => <<'END_OF_FUNC', |
| 1942 | | | | | sub path_info { |
| 1943 | | | | | my ($self,$info) = self_or_default(@_); |
| 1944 | | | | | if (defined($info)) { |
| 1945 | | | | | $info = "/$info" if $info ne '' && substr($info,0,1) ne '/'; |
| 1946 | | | | | $self->{'.path_info'} = $info; |
| 1947 | | | | | } elsif (! defined($self->{'.path_info'}) ) { |
| 1948 | | | | | my (undef,$path_info) = $self->_name_and_path_from_env; |
| 1949 | | | | | $self->{'.path_info'} = $path_info || ''; |
| 1950 | | | | | } |
| 1951 | | | | | return $self->{'.path_info'}; |
| 1952 | | | | | } |
| 1953 | | | | | END_OF_FUNC |
| 1954 | | | | | |
| 1955 | | | | | # This function returns a potentially modified version of SCRIPT_NAME |
| 1956 | | | | | # and PATH_INFO. Some HTTP servers do sanitise the paths in those |
| 1957 | | | | | # variables. It is the case of at least Apache 2. If for instance the |
| 1958 | | | | | # user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set: |
| 1959 | | | | | # REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y |
| 1960 | | | | | # SCRIPT_NAME=/path/to/env.cgi |
| 1961 | | | | | # PATH_INFO=/x/y/x |
| 1962 | | | | | # |
| 1963 | | | | | # This is all fine except that some bogus CGI scripts expect |
| 1964 | | | | | # PATH_INFO=/http://foo when the user requests |
| 1965 | | | | | # http://xxx/script.cgi/http://foo |
| 1966 | | | | | # |
| 1967 | | | | | # Old versions of this module used to accomodate with those scripts, so |
| 1968 | | | | | # this is why we do this here to keep those scripts backward compatible. |
| 1969 | | | | | # Basically, we accomodate with those scripts but within limits, that is |
| 1970 | | | | | # we only try to preserve the number of / that were provided by the user |
| 1971 | | | | | # if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number |
| 1972 | | | | | # of consecutive /. |
| 1973 | | | | | # |
| 1974 | | | | | # So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a |
| 1975 | | | | | # script_name of /x//y/script.cgi and a path_info of /a//b, but in: |
| 1976 | | | | | # http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions |
| 1977 | | | | | # possibly sanitised by the HTTP server, so in the case of Apache 2: |
| 1978 | | | | | # script_name == /foo/x/z/script.cgi and path_info == /b/c. |
| 1979 | | | | | # |
| 1980 | | | | | # Future versions of this module may no longer do that, so one should |
| 1981 | | | | | # avoid relying on the browser, proxy, server, and CGI.pm preserving the |
| 1982 | | | | | # number of consecutive slashes as no guarantee can be made there. |
| 1983 | | | | | '_name_and_path_from_env' => <<'END_OF_FUNC', |
| 1984 | | | | | sub _name_and_path_from_env { |
| 1985 | | | | | my $self = shift; |
| 1986 | | | | | my $script_name = $ENV{SCRIPT_NAME} || ''; |
| 1987 | | | | | my $path_info = $ENV{PATH_INFO} || ''; |
| 1988 | | | | | my $uri = $self->request_uri || ''; |
| 1989 | | | | | |
| 1990 | | | | | $uri =~ s/\?.*//s; |
| 1991 | | | | | $uri = unescape($uri); |
| 1992 | | | | | |
| 1993 | | | | | if ( $IIS ) { |
| 1994 | | | | | # IIS doesn't set $ENV{PATH_INFO} correctly. It sets it to |
| 1995 | | | | | # $ENV{SCRIPT_NAME}path_info |
| 1996 | | | | | # IIS also doesn't set $ENV{REQUEST_URI} so we don't want to do |
| 1997 | | | | | # the test below, hence this comes first |
| 1998 | | | | | $path_info =~ s/^\Q$script_name\E(.*)/$1/; |
| 1999 | | | | | } elsif ($uri ne "$script_name$path_info") { |
| 2000 | | | | | my $script_name_pattern = quotemeta($script_name); |
| 2001 | | | | | my $path_info_pattern = quotemeta($path_info); |
| 2002 | | | | | $script_name_pattern =~ s{(?:\\/)+}{/+}g; |
| 2003 | | | | | $path_info_pattern =~ s{(?:\\/)+}{/+}g; |
| 2004 | | | | | |
| 2005 | | | | | if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) { |
| 2006 | | | | | # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the |
| 2007 | | | | | # numer of consecutive slashes, so we can extract the info from |
| 2008 | | | | | # REQUEST_URI: |
| 2009 | | | | | ($script_name, $path_info) = ($1, $2); |
| 2010 | | | | | } |
| 2011 | | | | | } |
| 2012 | | | | | return ($script_name,$path_info); |
| 2013 | | | | | } |
| 2014 | | | | | END_OF_FUNC |
| 2015 | | | | | |
| 2016 | | | | | |
| 2017 | | | | | #### Method: request_method |
| 2018 | | | | | # Returns 'POST', 'GET', 'PUT' or 'HEAD' |
| 2019 | | | | | #### |
| 2020 | | | | | 'request_method' => <<'END_OF_FUNC', |
| 2021 | | | | | sub request_method { |
| 2022 | | | | | return (defined $ENV{'REQUEST_METHOD'}) ? $ENV{'REQUEST_METHOD'} : undef; |
| 2023 | | | | | } |
| 2024 | | | | | END_OF_FUNC |
| 2025 | | | | | |
| 2026 | | | | | #### Method: content_type |
| 2027 | | | | | # Returns the content_type string |
| 2028 | | | | | #### |
| 2029 | | | | | 'content_type' => <<'END_OF_FUNC', |
| 2030 | | | | | sub content_type { |
| 2031 | | | | | return (defined $ENV{'CONTENT_TYPE'}) ? $ENV{'CONTENT_TYPE'} : undef; |
| 2032 | | | | | } |
| 2033 | | | | | END_OF_FUNC |
| 2034 | | | | | |
| 2035 | | | | | #### Method: path_translated |
| 2036 | | | | | # Return the physical path information provided |
| 2037 | | | | | # by the URL (if any) |
| 2038 | | | | | #### |
| 2039 | | | | | 'path_translated' => <<'END_OF_FUNC', |
| 2040 | | | | | sub path_translated { |
| 2041 | | | | | return (defined $ENV{'PATH_TRANSLATED'}) ? $ENV{'PATH_TRANSLATED'} : undef; |
| 2042 | | | | | } |
| 2043 | | | | | END_OF_FUNC |
| 2044 | | | | | |
| 2045 | | | | | |
| 2046 | | | | | #### Method: request_uri |
| 2047 | | | | | # Return the literal request URI |
| 2048 | | | | | #### |
| 2049 | | | | | 'request_uri' => <<'END_OF_FUNC', |
| 2050 | | | | | sub request_uri { |
| 2051 | | | | | return (defined $ENV{'REQUEST_URI'}) ? $ENV{'REQUEST_URI'} : undef; |
| 2052 | | | | | } |
| 2053 | | | | | END_OF_FUNC |
| 2054 | | | | | |
| 2055 | | | | | |
| 2056 | | | | | #### Method: query_string |
| 2057 | | | | | # Synthesize a query string from our current |
| 2058 | | | | | # parameters |
| 2059 | | | | | #### |
| 2060 | | | | | 'query_string' => <<'END_OF_FUNC', |
| 2061 | | | | | sub query_string { |
| 2062 | | | | | my($self) = self_or_default(@_); |
| 2063 | | | | | my($param,$value,@pairs); |
| 2064 | | | | | for $param ($self->param) { |
| 2065 | | | | | my($eparam) = escape($param); |
| 2066 | | | | | for $value ($self->param($param)) { |
| 2067 | | | | | $value = escape($value); |
| 2068 | | | | | next unless defined $value; |
| 2069 | | | | | push(@pairs,"$eparam=$value"); |
| 2070 | | | | | } |
| 2071 | | | | | } |
| 2072 | | | | | for (keys %{$self->{'.fieldnames'}}) { |
| 2073 | | | | | push(@pairs,".cgifields=".escape("$_")); |
| 2074 | | | | | } |
| 2075 | | | | | return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs); |
| 2076 | | | | | } |
| 2077 | | | | | END_OF_FUNC |
| 2078 | | | | | |
| 2079 | | | | | |
| 2080 | | | | | #### Method: accept |
| 2081 | | | | | # Without parameters, returns an array of the |
| 2082 | | | | | # MIME types the browser accepts. |
| 2083 | | | | | # With a single parameter equal to a MIME |
| 2084 | | | | | # type, will return undef if the browser won't |
| 2085 | | | | | # accept it, 1 if the browser accepts it but |
| 2086 | | | | | # doesn't give a preference, or a floating point |
| 2087 | | | | | # value between 0.0 and 1.0 if the browser |
| 2088 | | | | | # declares a quantitative score for it. |
| 2089 | | | | | # This handles MIME type globs correctly. |
| 2090 | | | | | #### |
| 2091 | | | | | 'Accept' => <<'END_OF_FUNC', |
| 2092 | | | | | sub Accept { |
| 2093 | | | | | my($self,$search) = self_or_CGI(@_); |
| 2094 | | | | | my(%prefs,$type,$pref,$pat); |
| 2095 | | | | | |
| 2096 | | | | | my(@accept) = defined $self->http('accept') |
| 2097 | | | | | ? split(',',$self->http('accept')) |
| 2098 | | | | | : (); |
| 2099 | | | | | |
| 2100 | | | | | for (@accept) { |
| 2101 | | | | | ($pref) = /q=(\d\.\d+|\d+)/; |
| 2102 | | | | | ($type) = m#(\S+/[^;]+)#; |
| 2103 | | | | | next unless $type; |
| 2104 | | | | | $prefs{$type}=$pref || 1; |
| 2105 | | | | | } |
| 2106 | | | | | |
| 2107 | | | | | return keys %prefs unless $search; |
| 2108 | | | | | |
| 2109 | | | | | # if a search type is provided, we may need to |
| 2110 | | | | | # perform a pattern matching operation. |
| 2111 | | | | | # The MIME types use a glob mechanism, which |
| 2112 | | | | | # is easily translated into a perl pattern match |
| 2113 | | | | | |
| 2114 | | | | | # First return the preference for directly supported |
| 2115 | | | | | # types: |
| 2116 | | | | | return $prefs{$search} if $prefs{$search}; |
| 2117 | | | | | |
| 2118 | | | | | # Didn't get it, so try pattern matching. |
| 2119 | | | | | for (keys %prefs) { |
| 2120 | | | | | next unless /\*/; # not a pattern match |
| 2121 | | | | | ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters |
| 2122 | | | | | $pat =~ s/\*/.*/g; # turn it into a pattern |
| 2123 | | | | | return $prefs{$_} if $search=~/$pat/; |
| 2124 | | | | | } |
| 2125 | | | | | } |
| 2126 | | | | | END_OF_FUNC |
| 2127 | | | | | |
| 2128 | | | | | |
| 2129 | | | | | #### Method: user_agent |
| 2130 | | | | | # If called with no parameters, returns the user agent. |
| 2131 | | | | | # If called with one parameter, does a pattern match (case |
| 2132 | | | | | # insensitive) on the user agent. |
| 2133 | | | | | #### |
| 2134 | | | | | 'user_agent' => <<'END_OF_FUNC', |
| 2135 | | | | | sub user_agent { |
| 2136 | | | | | my($self,$match)=self_or_CGI(@_); |
| 2137 | | | | | my $user_agent = $self->http('user_agent'); |
| 2138 | | | | | return $user_agent unless defined $match && $match && $user_agent; |
| 2139 | | | | | return $user_agent =~ /$match/i; |
| 2140 | | | | | } |
| 2141 | | | | | END_OF_FUNC |
| 2142 | | | | | |
| 2143 | | | | | |
| 2144 | | | | | #### Method: raw_cookie |
| 2145 | | | | | # Returns the magic cookies for the session. |
| 2146 | | | | | # The cookies are not parsed or altered in any way, i.e. |
| 2147 | | | | | # cookies are returned exactly as given in the HTTP |
| 2148 | | | | | # headers. If a cookie name is given, only that cookie's |
| 2149 | | | | | # value is returned, otherwise the entire raw cookie |
| 2150 | | | | | # is returned. |
| 2151 | | | | | #### |
| 2152 | | | | | 'raw_cookie' => <<'END_OF_FUNC', |
| 2153 | | | | | sub raw_cookie { |
| 2154 | | | | | my($self,$key) = self_or_CGI(@_); |
| 2155 | | | | | |
| 2156 | | | | | require CGI::Cookie; |
| 2157 | | | | | |
| 2158 | | | | | if (defined($key)) { |
| 2159 | | | | | $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch |
| 2160 | | | | | unless $self->{'.raw_cookies'}; |
| 2161 | | | | | |
| 2162 | | | | | return () unless $self->{'.raw_cookies'}; |
| 2163 | | | | | return () unless $self->{'.raw_cookies'}->{$key}; |
| 2164 | | | | | return $self->{'.raw_cookies'}->{$key}; |
| 2165 | | | | | } |
| 2166 | | | | | return $self->http('cookie') || $ENV{'COOKIE'} || ''; |
| 2167 | | | | | } |
| 2168 | | | | | END_OF_FUNC |
| 2169 | | | | | |
| 2170 | | | | | #### Method: virtual_host |
| 2171 | | | | | # Return the name of the virtual_host, which |
| 2172 | | | | | # is not always the same as the server |
| 2173 | | | | | ###### |
| 2174 | | | | | 'virtual_host' => <<'END_OF_FUNC', |
| 2175 | | | | | sub virtual_host { |
| 2176 | | | | | my $vh = http('x_forwarded_host') || http('host') || server_name(); |
| 2177 | | | | | $vh =~ s/:\d+$//; # get rid of port number |
| 2178 | | | | | return $vh; |
| 2179 | | | | | } |
| 2180 | | | | | END_OF_FUNC |
| 2181 | | | | | |
| 2182 | | | | | #### Method: remote_host |
| 2183 | | | | | # Return the name of the remote host, or its IP |
| 2184 | | | | | # address if unavailable. If this variable isn't |
| 2185 | | | | | # defined, it returns "localhost" for debugging |
| 2186 | | | | | # purposes. |
| 2187 | | | | | #### |
| 2188 | | | | | 'remote_host' => <<'END_OF_FUNC', |
| 2189 | | | | | sub remote_host { |
| 2190 | | | | | return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} |
| 2191 | | | | | || 'localhost'; |
| 2192 | | | | | } |
| 2193 | | | | | END_OF_FUNC |
| 2194 | | | | | |
| 2195 | | | | | |
| 2196 | | | | | #### Method: remote_addr |
| 2197 | | | | | # Return the IP addr of the remote host. |
| 2198 | | | | | #### |
| 2199 | | | | | 'remote_addr' => <<'END_OF_FUNC', |
| 2200 | | | | | sub remote_addr { |
| 2201 | | | | | return $ENV{'REMOTE_ADDR'} || '127.0.0.1'; |
| 2202 | | | | | } |
| 2203 | | | | | END_OF_FUNC |
| 2204 | | | | | |
| 2205 | | | | | |
| 2206 | | | | | #### Method: script_name |
| 2207 | | | | | # Return the partial URL to this script for |
| 2208 | | | | | # self-referencing scripts. Also see |
| 2209 | | | | | # self_url(), which returns a URL with all state information |
| 2210 | | | | | # preserved. |
| 2211 | | | | | #### |
| 2212 | | | | | 'script_name' => <<'END_OF_FUNC', |
| 2213 | | | | | sub script_name { |
| 2214 | | | | | my ($self,@p) = self_or_default(@_); |
| 2215 | | | | | if (@p) { |
| 2216 | | | | | $self->{'.script_name'} = shift @p; |
| 2217 | | | | | } elsif (!exists $self->{'.script_name'}) { |
| 2218 | | | | | my ($script_name,$path_info) = $self->_name_and_path_from_env(); |
| 2219 | | | | | $self->{'.script_name'} = $script_name; |
| 2220 | | | | | } |
| 2221 | | | | | return $self->{'.script_name'}; |
| 2222 | | | | | } |
| 2223 | | | | | END_OF_FUNC |
| 2224 | | | | | |
| 2225 | | | | | |
| 2226 | | | | | #### Method: referer |
| 2227 | | | | | # Return the HTTP_REFERER: useful for generating |
| 2228 | | | | | # a GO BACK button. |
| 2229 | | | | | #### |
| 2230 | | | | | 'referer' => <<'END_OF_FUNC', |
| 2231 | | | | | sub referer { |
| 2232 | | | | | my($self) = self_or_CGI(@_); |
| 2233 | | | | | return $self->http('referer'); |
| 2234 | | | | | } |
| 2235 | | | | | END_OF_FUNC |
| 2236 | | | | | |
| 2237 | | | | | |
| 2238 | | | | | #### Method: server_name |
| 2239 | | | | | # Return the name of the server |
| 2240 | | | | | #### |
| 2241 | | | | | 'server_name' => <<'END_OF_FUNC', |
| 2242 | | | | | sub server_name { |
| 2243 | | | | | return $ENV{'SERVER_NAME'} || 'localhost'; |
| 2244 | | | | | } |
| 2245 | | | | | END_OF_FUNC |
| 2246 | | | | | |
| 2247 | | | | | #### Method: server_software |
| 2248 | | | | | # Return the name of the server software |
| 2249 | | | | | #### |
| 2250 | | | | | 'server_software' => <<'END_OF_FUNC', |
| 2251 | | | | | sub server_software { |
| 2252 | | | | | return $ENV{'SERVER_SOFTWARE'} || 'cmdline'; |
| 2253 | | | | | } |
| 2254 | | | | | END_OF_FUNC |
| 2255 | | | | | |
| 2256 | | | | | #### Method: virtual_port |
| 2257 | | | | | # Return the server port, taking virtual hosts into account |
| 2258 | | | | | #### |
| 2259 | | | | | 'virtual_port' => <<'END_OF_FUNC', |
| 2260 | | | | | sub virtual_port { |
| 2261 | | | | | my($self) = self_or_default(@_); |
| 2262 | | | | | my $vh = $self->http('x_forwarded_host') || $self->http('host'); |
| 2263 | | | | | my $protocol = $self->protocol; |
| 2264 | | | | | if ($vh) { |
| 2265 | | | | | return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80); |
| 2266 | | | | | } else { |
| 2267 | | | | | return $self->server_port(); |
| 2268 | | | | | } |
| 2269 | | | | | } |
| 2270 | | | | | END_OF_FUNC |
| 2271 | | | | | |
| 2272 | | | | | #### Method: server_port |
| 2273 | | | | | # Return the tcp/ip port the server is running on |
| 2274 | | | | | #### |
| 2275 | | | | | 'server_port' => <<'END_OF_FUNC', |
| 2276 | | | | | sub server_port { |
| 2277 | | | | | return $ENV{'SERVER_PORT'} || 80; # for debugging |
| 2278 | | | | | } |
| 2279 | | | | | END_OF_FUNC |
| 2280 | | | | | |
| 2281 | | | | | #### Method: server_protocol |
| 2282 | | | | | # Return the protocol (usually HTTP/1.0) |
| 2283 | | | | | #### |
| 2284 | | | | | 'server_protocol' => <<'END_OF_FUNC', |
| 2285 | | | | | sub server_protocol { |
| 2286 | | | | | return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging |
| 2287 | | | | | } |
| 2288 | | | | | END_OF_FUNC |
| 2289 | | | | | |
| 2290 | | | | | #### Method: http |
| 2291 | | | | | # Return the value of an HTTP variable, or |
| 2292 | | | | | # the list of variables if none provided |
| 2293 | | | | | #### |
| 2294 | | | | | 'http' => <<'END_OF_FUNC', |
| 2295 | | | | | sub http { |
| 2296 | | | | | my ($self,$parameter) = self_or_CGI(@_); |
| 2297 | | | | | if ( defined($parameter) ) { |
| 2298 | | | | | $parameter =~ tr/-a-z/_A-Z/; |
| 2299 | | | | | if ( $parameter =~ /^HTTP(?:_|$)/ ) { |
| 2300 | | | | | return $ENV{$parameter}; |
| 2301 | | | | | } |
| 2302 | | | | | return $ENV{"HTTP_$parameter"}; |
| 2303 | | | | | } |
| 2304 | | | | | return grep { /^HTTP(?:_|$)/ } keys %ENV; |
| 2305 | | | | | } |
| 2306 | | | | | END_OF_FUNC |
| 2307 | | | | | |
| 2308 | | | | | #### Method: https |
| 2309 | | | | | # Return the value of HTTPS, or |
| 2310 | | | | | # the value of an HTTPS variable, or |
| 2311 | | | | | # the list of variables |
| 2312 | | | | | #### |
| 2313 | | | | | 'https' => <<'END_OF_FUNC', |
| 2314 | | | | | sub https { |
| 2315 | | | | | my ($self,$parameter) = self_or_CGI(@_); |
| 2316 | | | | | if ( defined($parameter) ) { |
| 2317 | | | | | $parameter =~ tr/-a-z/_A-Z/; |
| 2318 | | | | | if ( $parameter =~ /^HTTPS(?:_|$)/ ) { |
| 2319 | | | | | return $ENV{$parameter}; |
| 2320 | | | | | } |
| 2321 | | | | | return $ENV{"HTTPS_$parameter"}; |
| 2322 | | | | | } |
| 2323 | | | | | return wantarray |
| 2324 | | | | | ? grep { /^HTTPS(?:_|$)/ } keys %ENV |
| 2325 | | | | | : $ENV{'HTTPS'}; |
| 2326 | | | | | } |
| 2327 | | | | | END_OF_FUNC |
| 2328 | | | | | |
| 2329 | | | | | #### Method: protocol |
| 2330 | | | | | # Return the protocol (http or https currently) |
| 2331 | | | | | #### |
| 2332 | | | | | 'protocol' => <<'END_OF_FUNC', |
| 2333 | | | | | sub protocol { |
| 2334 | | | | | local($^W)=0; |
| 2335 | | | | | my $self = shift; |
| 2336 | | | | | return 'https' if uc($self->https()) eq 'ON'; |
| 2337 | | | | | return 'https' if $self->server_port == 443; |
| 2338 | | | | | my $prot = $self->server_protocol; |
| 2339 | | | | | my($protocol,$version) = split('/',$prot); |
| 2340 | | | | | return "\L$protocol\E"; |
| 2341 | | | | | } |
| 2342 | | | | | END_OF_FUNC |
| 2343 | | | | | |
| 2344 | | | | | #### Method: remote_ident |
| 2345 | | | | | # Return the identity of the remote user |
| 2346 | | | | | # (but only if his host is running identd) |
| 2347 | | | | | #### |
| 2348 | | | | | 'remote_ident' => <<'END_OF_FUNC', |
| 2349 | | | | | sub remote_ident { |
| 2350 | | | | | return (defined $ENV{'REMOTE_IDENT'}) ? $ENV{'REMOTE_IDENT'} : undef; |
| 2351 | | | | | } |
| 2352 | | | | | END_OF_FUNC |
| 2353 | | | | | |
| 2354 | | | | | |
| 2355 | | | | | #### Method: auth_type |
| 2356 | | | | | # Return the type of use verification/authorization in use, if any. |
| 2357 | | | | | #### |
| 2358 | | | | | 'auth_type' => <<'END_OF_FUNC', |
| 2359 | | | | | sub auth_type { |
| 2360 | | | | | return (defined $ENV{'AUTH_TYPE'}) ? $ENV{'AUTH_TYPE'} : undef; |
| 2361 | | | | | } |
| 2362 | | | | | END_OF_FUNC |
| 2363 | | | | | |
| 2364 | | | | | |
| 2365 | | | | | #### Method: remote_user |
| 2366 | | | | | # Return the authorization name used for user |
| 2367 | | | | | # verification. |
| 2368 | | | | | #### |
| 2369 | | | | | 'remote_user' => <<'END_OF_FUNC', |
| 2370 | | | | | sub remote_user { |
| 2371 | | | | | return (defined $ENV{'REMOTE_USER'}) ? $ENV{'REMOTE_USER'} : undef; |
| 2372 | | | | | } |
| 2373 | | | | | END_OF_FUNC |
| 2374 | | | | | |
| 2375 | | | | | |
| 2376 | | | | | #### Method: user_name |
| 2377 | | | | | # Try to return the remote user's name by hook or by |
| 2378 | | | | | # crook |
| 2379 | | | | | #### |
| 2380 | | | | | 'user_name' => <<'END_OF_FUNC', |
| 2381 | | | | | sub user_name { |
| 2382 | | | | | my ($self) = self_or_CGI(@_); |
| 2383 | | | | | return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'}; |
| 2384 | | | | | } |
| 2385 | | | | | END_OF_FUNC |
| 2386 | | | | | |
| 2387 | | | | | #### Method: nosticky |
| 2388 | | | | | # Set or return the NOSTICKY global flag |
| 2389 | | | | | #### |
| 2390 | | | | | 'nosticky' => <<'END_OF_FUNC', |
| 2391 | | | | | sub nosticky { |
| 2392 | | | | | my ($self,$param) = self_or_CGI(@_); |
| 2393 | | | | | $CGI::NOSTICKY = $param if defined($param); |
| 2394 | | | | | return $CGI::NOSTICKY; |
| 2395 | | | | | } |
| 2396 | | | | | END_OF_FUNC |
| 2397 | | | | | |
| 2398 | | | | | #### Method: nph |
| 2399 | | | | | # Set or return the NPH global flag |
| 2400 | | | | | #### |
| 2401 | | | | | 'nph' => <<'END_OF_FUNC', |
| 2402 | | | | | sub nph { |
| 2403 | | | | | my ($self,$param) = self_or_CGI(@_); |
| 2404 | | | | | $CGI::NPH = $param if defined($param); |
| 2405 | | | | | return $CGI::NPH; |
| 2406 | | | | | } |
| 2407 | | | | | END_OF_FUNC |
| 2408 | | | | | |
| 2409 | | | | | #### Method: private_tempfiles |
| 2410 | | | | | # Set or return the private_tempfiles global flag |
| 2411 | | | | | #### |
| 2412 | | | | | 'private_tempfiles' => <<'END_OF_FUNC', |
| 2413 | | | | | sub private_tempfiles { |
| 2414 | | | | | warn "private_tempfiles has been deprecated"; |
| 2415 | | | | | return 0; |
| 2416 | | | | | } |
| 2417 | | | | | END_OF_FUNC |
| 2418 | | | | | #### Method: close_upload_files |
| 2419 | | | | | # Set or return the close_upload_files global flag |
| 2420 | | | | | #### |
| 2421 | | | | | 'close_upload_files' => <<'END_OF_FUNC', |
| 2422 | | | | | sub close_upload_files { |
| 2423 | | | | | my ($self,$param) = self_or_CGI(@_); |
| 2424 | | | | | $CGI::CLOSE_UPLOAD_FILES = $param if defined($param); |
| 2425 | | | | | return $CGI::CLOSE_UPLOAD_FILES; |
| 2426 | | | | | } |
| 2427 | | | | | END_OF_FUNC |
| 2428 | | | | | |
| 2429 | | | | | |
| 2430 | | | | | #### Method: default_dtd |
| 2431 | | | | | # Set or return the default_dtd global |
| 2432 | | | | | #### |
| 2433 | | | | | 'default_dtd' => <<'END_OF_FUNC', |
| 2434 | | | | | sub default_dtd { |
| 2435 | | | | | my ($self,$param,$param2) = self_or_CGI(@_); |
| 2436 | | | | | if (defined $param2 && defined $param) { |
| 2437 | | | | | $CGI::DEFAULT_DTD = [ $param, $param2 ]; |
| 2438 | | | | | } elsif (defined $param) { |
| 2439 | | | | | $CGI::DEFAULT_DTD = $param; |
| 2440 | | | | | } |
| 2441 | | | | | return $CGI::DEFAULT_DTD; |
| 2442 | | | | | } |
| 2443 | | | | | END_OF_FUNC |
| 2444 | | | | | |
| 2445 | | | | | # -------------- really private subroutines ----------------- |
| 2446 | | | | | '_maybe_escapeHTML' => <<'END_OF_FUNC', |
| 2447 | | | | | sub _maybe_escapeHTML { |
| 2448 | | | | | # hack to work around earlier hacks |
| 2449 | | | | | push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; |
| 2450 | | | | | my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_); |
| 2451 | | | | | return undef unless defined($toencode); |
| 2452 | | | | | return $toencode if ref($self) && !$self->{'escape'}; |
| 2453 | | | | | return $self->escapeHTML($toencode, $newlinestoo); |
| 2454 | | | | | } |
| 2455 | | | | | END_OF_FUNC |
| 2456 | | | | | |
| 2457 | | | | | 'previous_or_default' => <<'END_OF_FUNC', |
| 2458 | | | | | sub previous_or_default { |
| 2459 | | | | | my($self,$name,$defaults,$override) = @_; |
| 2460 | | | | | my(%selected); |
| 2461 | | | | | |
| 2462 | | | | | if (!$override && ($self->{'.fieldnames'}->{$name} || |
| 2463 | | | | | defined($self->param($name)) ) ) { |
| 2464 | | | | | $selected{$_}++ for $self->param($name); |
| 2465 | | | | | } elsif (defined($defaults) && ref($defaults) && |
| 2466 | | | | | (ref($defaults) eq 'ARRAY')) { |
| 2467 | | | | | $selected{$_}++ for @{$defaults}; |
| 2468 | | | | | } else { |
| 2469 | | | | | $selected{$defaults}++ if defined($defaults); |
| 2470 | | | | | } |
| 2471 | | | | | |
| 2472 | | | | | return %selected; |
| 2473 | | | | | } |
| 2474 | | | | | END_OF_FUNC |
| 2475 | | | | | |
| 2476 | | | | | 'register_parameter' => <<'END_OF_FUNC', |
| 2477 | | | | | sub register_parameter { |
| 2478 | | | | | my($self,$param) = @_; |
| 2479 | | | | | $self->{'.parametersToAdd'}->{$param}++; |
| 2480 | | | | | } |
| 2481 | | | | | END_OF_FUNC |
| 2482 | | | | | |
| 2483 | | | | | 'get_fields' => <<'END_OF_FUNC', |
| 2484 | | | | | sub get_fields { |
| 2485 | | | | | my($self) = @_; |
| 2486 | | | | | return $self->CGI::hidden('-name'=>'.cgifields', |
| 2487 | | | | | '-values'=>[keys %{$self->{'.parametersToAdd'}}], |
| 2488 | | | | | '-override'=>1); |
| 2489 | | | | | } |
| 2490 | | | | | END_OF_FUNC |
| 2491 | | | | | |
| 2492 | | | | | 'read_from_cmdline' => <<'END_OF_FUNC', |
| 2493 | | | | | sub read_from_cmdline { |
| 2494 | | | | | my($input,@words); |
| 2495 | | | | | my($query_string); |
| 2496 | | | | | my($subpath); |
| 2497 | | | | | if ($DEBUG && @ARGV) { |
| 2498 | | | | | @words = @ARGV; |
| 2499 | | | | | } elsif ($DEBUG > 1) { |
| 2500 | | | | | require Text::ParseWords; |
| 2501 | | | | | print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n"; |
| 2502 | | | | | chomp(@lines = <STDIN>); # remove newlines |
| 2503 | | | | | $input = join(" ",@lines); |
| 2504 | | | | | @words = &Text::ParseWords::old_shellwords($input); |
| 2505 | | | | | } |
| 2506 | | | | | for (@words) { |
| 2507 | | | | | s/\\=/%3D/g; |
| 2508 | | | | | s/\\&/%26/g; |
| 2509 | | | | | } |
| 2510 | | | | | |
| 2511 | | | | | if ("@words"=~/=/) { |
| 2512 | | | | | $query_string = join('&',@words); |
| 2513 | | | | | } else { |
| 2514 | | | | | $query_string = join('+',@words); |
| 2515 | | | | | } |
| 2516 | | | | | if ($query_string =~ /^(.*?)\?(.*)$/) |
| 2517 | | | | | { |
| 2518 | | | | | $query_string = $2; |
| 2519 | | | | | $subpath = $1; |
| 2520 | | | | | } |
| 2521 | | | | | return { 'query_string' => $query_string, 'subpath' => $subpath }; |
| 2522 | | | | | } |
| 2523 | | | | | END_OF_FUNC |
| 2524 | | | | | |
| 2525 | | | | | ##### |
| 2526 | | | | | # subroutine: read_multipart |
| 2527 | | | | | # |
| 2528 | | | | | # Read multipart data and store it into our parameters. |
| 2529 | | | | | # An interesting feature is that if any of the parts is a file, we |
| 2530 | | | | | # create a temporary file and open up a filehandle on it so that the |
| 2531 | | | | | # caller can read from it if necessary. |
| 2532 | | | | | ##### |
| 2533 | | | | | 'read_multipart' => <<'END_OF_FUNC', |
| 2534 | | | | | sub read_multipart { |
| 2535 | | | | | my($self,$boundary,$length) = @_; |
| 2536 | | | | | my($buffer) = $self->new_MultipartBuffer($boundary,$length); |
| 2537 | | | | | return unless $buffer; |
| 2538 | | | | | my(%header,$body); |
| 2539 | | | | | my $filenumber = 0; |
| 2540 | | | | | while (!$buffer->eof) { |
| 2541 | | | | | %header = $buffer->readHeader; |
| 2542 | | | | | |
| 2543 | | | | | unless (%header) { |
| 2544 | | | | | $self->cgi_error("400 Bad request (malformed multipart POST)"); |
| 2545 | | | | | return; |
| 2546 | | | | | } |
| 2547 | | | | | |
| 2548 | | | | | $header{'Content-Disposition'} ||= ''; # quench uninit variable warning |
| 2549 | | | | | |
| 2550 | | | | | my($param)= $header{'Content-Disposition'}=~/[\s;]name="([^"]*)"/; |
| 2551 | | | | | $param .= $TAINTED; |
| 2552 | | | | | |
| 2553 | | | | | # See RFC 1867, 2183, 2045 |
| 2554 | | | | | # NB: File content will be loaded into memory should |
| 2555 | | | | | # content-disposition parsing fail. |
| 2556 | | | | | my ($filename) = $header{'Content-Disposition'} |
| 2557 | | | | | =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i; |
| 2558 | | | | | |
| 2559 | | | | | $filename ||= ''; # quench uninit variable warning |
| 2560 | | | | | |
| 2561 | | | | | $filename =~ s/^"([^"]*)"$/$1/; |
| 2562 | | | | | # Test for Opera's multiple upload feature |
| 2563 | | | | | my($multipart) = ( defined( $header{'Content-Type'} ) && |
| 2564 | | | | | $header{'Content-Type'} =~ /multipart\/mixed/ ) ? |
| 2565 | | | | | 1 : 0; |
| 2566 | | | | | |
| 2567 | | | | | # add this parameter to our list |
| 2568 | | | | | $self->add_parameter($param); |
| 2569 | | | | | |
| 2570 | | | | | # If no filename specified, then just read the data and assign it |
| 2571 | | | | | # to our parameter list. |
| 2572 | | | | | if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) { |
| 2573 | | | | | my($value) = $buffer->readBody; |
| 2574 | | | | | $value .= $TAINTED; |
| 2575 | | | | | push(@{$self->{param}{$param}},$value); |
| 2576 | | | | | next; |
| 2577 | | | | | } |
| 2578 | | | | | |
| 2579 | | | | | UPLOADS: { |
| 2580 | | | | | # If we get here, then we are dealing with a potentially large |
| 2581 | | | | | # uploaded form. Save the data to a temporary file, then open |
| 2582 | | | | | # the file for reading. |
| 2583 | | | | | |
| 2584 | | | | | # skip the file if uploads disabled |
| 2585 | | | | | if ($DISABLE_UPLOADS) { |
| 2586 | | | | | while (defined($data = $buffer->read)) { } |
| 2587 | | | | | last UPLOADS; |
| 2588 | | | | | } |
| 2589 | | | | | |
| 2590 | | | | | # set the filename to some recognizable value |
| 2591 | | | | | if ( ( !defined($filename) || $filename eq '' ) && $multipart ) { |
| 2592 | | | | | $filename = "multipart/mixed"; |
| 2593 | | | | | } |
| 2594 | | | | | |
| 2595 | | | | | my $tmp_dir = $CGI::OS eq 'WINDOWS' |
| 2596 | | | | | ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) ) |
| 2597 | | | | | : undef; # File::Temp defaults to TMPDIR |
| 2598 | | | | | |
| 2599 | | | | | my $filehandle = CGI::File::Temp->new( |
| 2600 | | | | | UNLINK => $UNLINK_TMP_FILES, |
| 2601 | | | | | DIR => $tmp_dir, |
| 2602 | | | | | ); |
| 2603 | | | | | $filehandle->_mp_filename( $filename ); |
| 2604 | | | | | |
| 2605 | | | | | $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode |
| 2606 | | | | | && defined fileno($filehandle); |
| 2607 | | | | | |
| 2608 | | | | | # if this is an multipart/mixed attachment, save the header |
| 2609 | | | | | # together with the body for later parsing with an external |
| 2610 | | | | | # MIME parser module |
| 2611 | | | | | if ( $multipart ) { |
| 2612 | | | | | for ( keys %header ) { |
| 2613 | | | | | print $filehandle "$_: $header{$_}${CRLF}"; |
| 2614 | | | | | } |
| 2615 | | | | | print $filehandle "${CRLF}"; |
| 2616 | | | | | } |
| 2617 | | | | | |
| 2618 | | | | | my ($data); |
| 2619 | | | | | local($\) = ''; |
| 2620 | | | | | my $totalbytes = 0; |
| 2621 | | | | | while (defined($data = $buffer->read)) { |
| 2622 | | | | | if (defined $self->{'.upload_hook'}) |
| 2623 | | | | | { |
| 2624 | | | | | $totalbytes += length($data); |
| 2625 | | | | | &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'}); |
| 2626 | | | | | } |
| 2627 | | | | | print $filehandle $data if ($self->{'use_tempfile'}); |
| 2628 | | | | | } |
| 2629 | | | | | |
| 2630 | | | | | # back up to beginning of file |
| 2631 | | | | | seek($filehandle,0,0); |
| 2632 | | | | | |
| 2633 | | | | | ## Close the filehandle if requested this allows a multipart MIME |
| 2634 | | | | | ## upload to contain many files, and we won't die due to too many |
| 2635 | | | | | ## open file handles. The user can access the files using the hash |
| 2636 | | | | | ## below. |
| 2637 | | | | | close $filehandle if $CLOSE_UPLOAD_FILES; |
| 2638 | | | | | $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; |
| 2639 | | | | | |
| 2640 | | | | | # Save some information about the uploaded file where we can get |
| 2641 | | | | | # at it later. |
| 2642 | | | | | # Use the typeglob + filename as the key, as this is guaranteed to be |
| 2643 | | | | | # unique for each filehandle. Don't use the file descriptor as |
| 2644 | | | | | # this will be re-used for each filehandle if the |
| 2645 | | | | | # close_upload_files feature is used. |
| 2646 | | | | | $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = { |
| 2647 | | | | | hndl => $filehandle, |
| 2648 | | | | | name => $filehandle->filename, |
| 2649 | | | | | info => {%header}, |
| 2650 | | | | | }; |
| 2651 | | | | | push(@{$self->{param}{$param}},$filehandle); |
| 2652 | | | | | } |
| 2653 | | | | | } |
| 2654 | | | | | } |
| 2655 | | | | | END_OF_FUNC |
| 2656 | | | | | |
| 2657 | | | | | ##### |
| 2658 | | | | | # subroutine: read_multipart_related |
| 2659 | | | | | # |
| 2660 | | | | | # Read multipart/related data and store it into our parameters. The |
| 2661 | | | | | # first parameter sets the start of the data. The part identified by |
| 2662 | | | | | # this Content-ID will not be stored as a file upload, but will be |
| 2663 | | | | | # returned by this method. All other parts will be available as file |
| 2664 | | | | | # uploads accessible by their Content-ID |
| 2665 | | | | | ##### |
| 2666 | | | | | 'read_multipart_related' => <<'END_OF_FUNC', |
| 2667 | | | | | sub read_multipart_related { |
| 2668 | | | | | my($self,$start,$boundary,$length) = @_; |
| 2669 | | | | | my($buffer) = $self->new_MultipartBuffer($boundary,$length); |
| 2670 | | | | | return unless $buffer; |
| 2671 | | | | | my(%header,$body); |
| 2672 | | | | | my $filenumber = 0; |
| 2673 | | | | | my $returnvalue; |
| 2674 | | | | | while (!$buffer->eof) { |
| 2675 | | | | | %header = $buffer->readHeader; |
| 2676 | | | | | |
| 2677 | | | | | unless (%header) { |
| 2678 | | | | | $self->cgi_error("400 Bad request (malformed multipart POST)"); |
| 2679 | | | | | return; |
| 2680 | | | | | } |
| 2681 | | | | | |
| 2682 | | | | | my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/; |
| 2683 | | | | | $param .= $TAINTED; |
| 2684 | | | | | |
| 2685 | | | | | # If this is the start part, then just read the data and assign it |
| 2686 | | | | | # to our return variable. |
| 2687 | | | | | if ( $param eq $start ) { |
| 2688 | | | | | $returnvalue = $buffer->readBody; |
| 2689 | | | | | $returnvalue .= $TAINTED; |
| 2690 | | | | | next; |
| 2691 | | | | | } |
| 2692 | | | | | |
| 2693 | | | | | # add this parameter to our list |
| 2694 | | | | | $self->add_parameter($param); |
| 2695 | | | | | |
| 2696 | | | | | UPLOADS: { |
| 2697 | | | | | # If we get here, then we are dealing with a potentially large |
| 2698 | | | | | # uploaded form. Save the data to a temporary file, then open |
| 2699 | | | | | # the file for reading. |
| 2700 | | | | | |
| 2701 | | | | | # skip the file if uploads disabled |
| 2702 | | | | | if ($DISABLE_UPLOADS) { |
| 2703 | | | | | while (defined($data = $buffer->read)) { } |
| 2704 | | | | | last UPLOADS; |
| 2705 | | | | | } |
| 2706 | | | | | |
| 2707 | | | | | my $tmp_dir = $CGI::OS eq 'WINDOWS' |
| 2708 | | | | | ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) ) |
| 2709 | | | | | : undef; # File::Temp defaults to TMPDIR |
| 2710 | | | | | |
| 2711 | | | | | my $filehandle = CGI::File::Temp->new( |
| 2712 | | | | | UNLINK => $UNLINK_TMP_FILES, |
| 2713 | | | | | DIR => $tmp_dir, |
| 2714 | | | | | ); |
| 2715 | | | | | $filehandle->_mp_filename( $filehandle->filename ); |
| 2716 | | | | | |
| 2717 | | | | | $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode |
| 2718 | | | | | && defined fileno($filehandle); |
| 2719 | | | | | |
| 2720 | | | | | my ($data); |
| 2721 | | | | | local($\) = ''; |
| 2722 | | | | | my $totalbytes; |
| 2723 | | | | | while (defined($data = $buffer->read)) { |
| 2724 | | | | | if (defined $self->{'.upload_hook'}) |
| 2725 | | | | | { |
| 2726 | | | | | $totalbytes += length($data); |
| 2727 | | | | | &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'}); |
| 2728 | | | | | } |
| 2729 | | | | | print $filehandle $data if ($self->{'use_tempfile'}); |
| 2730 | | | | | } |
| 2731 | | | | | |
| 2732 | | | | | # back up to beginning of file |
| 2733 | | | | | seek($filehandle,0,0); |
| 2734 | | | | | |
| 2735 | | | | | ## Close the filehandle if requested this allows a multipart MIME |
| 2736 | | | | | ## upload to contain many files, and we won't die due to too many |
| 2737 | | | | | ## open file handles. The user can access the files using the hash |
| 2738 | | | | | ## below. |
| 2739 | | | | | close $filehandle if $CLOSE_UPLOAD_FILES; |
| 2740 | | | | | $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; |
| 2741 | | | | | |
| 2742 | | | | | # Save some information about the uploaded file where we can get |
| 2743 | | | | | # at it later. |
| 2744 | | | | | # Use the typeglob + filename as the key, as this is guaranteed to be |
| 2745 | | | | | # unique for each filehandle. Don't use the file descriptor as |
| 2746 | | | | | # this will be re-used for each filehandle if the |
| 2747 | | | | | # close_upload_files feature is used. |
| 2748 | | | | | $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = { |
| 2749 | | | | | hndl => $filehandle, |
| 2750 | | | | | name => $filehandle->filename, |
| 2751 | | | | | info => {%header}, |
| 2752 | | | | | }; |
| 2753 | | | | | push(@{$self->{param}{$param}},$filehandle); |
| 2754 | | | | | } |
| 2755 | | | | | } |
| 2756 | | | | | return $returnvalue; |
| 2757 | | | | | } |
| 2758 | | | | | END_OF_FUNC |
| 2759 | | | | | |
| 2760 | | | | | |
| 2761 | | | | | 'upload' =><<'END_OF_FUNC', |
| 2762 | | | | | sub upload { |
| 2763 | | | | | my($self,$param_name) = self_or_default(@_); |
| 2764 | | | | | my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name); |
| 2765 | | | | | return unless @param; |
| 2766 | | | | | return wantarray ? @param : $param[0]; |
| 2767 | | | | | } |
| 2768 | | | | | END_OF_FUNC |
| 2769 | | | | | |
| 2770 | | | | | 'tmpFileName' => <<'END_OF_FUNC', |
| 2771 | | | | | sub tmpFileName { |
| 2772 | | | | | my($self,$filename) = self_or_default(@_); |
| 2773 | | | | | return $self->{'.tmpfiles'}->{$$filename . $filename}->{name} || ''; |
| 2774 | | | | | } |
| 2775 | | | | | END_OF_FUNC |
| 2776 | | | | | |
| 2777 | | | | | 'uploadInfo' => <<'END_OF_FUNC', |
| 2778 | | | | | sub uploadInfo { |
| 2779 | | | | | my($self,$filename) = self_or_default(@_); |
| 2780 | | | | | return if ! defined $$filename; |
| 2781 | | | | | return $self->{'.tmpfiles'}->{$$filename . $filename}->{info}; |
| 2782 | | | | | } |
| 2783 | | | | | END_OF_FUNC |
| 2784 | | | | | |
| 2785 | | | | | # internal routine, don't use |
| 2786 | | | | | '_set_values_and_labels' => <<'END_OF_FUNC', |
| 2787 | | | | | sub _set_values_and_labels { |
| 2788 | | | | | my $self = shift; |
| 2789 | | | | | my ($v,$l,$n) = @_; |
| 2790 | | | | | $$l = $v if ref($v) eq 'HASH' && !ref($$l); |
| 2791 | | | | | return $self->param($n) if !defined($v); |
| 2792 | | | | | return $v if !ref($v); |
| 2793 | | | | | return ref($v) eq 'HASH' ? keys %$v : @$v; |
| 2794 | | | | | } |
| 2795 | | | | | END_OF_FUNC |
| 2796 | | | | | |
| 2797 | | | | | # internal routine, don't use |
| 2798 | | | | | '_set_attributes' => <<'END_OF_FUNC', |
| 2799 | | | | | sub _set_attributes { |
| 2800 | | | | | my $self = shift; |
| 2801 | | | | | my($element, $attributes) = @_; |
| 2802 | | | | | return '' unless defined($attributes->{$element}); |
| 2803 | | | | | $attribs = ' '; |
| 2804 | | | | | for my $attrib (keys %{$attributes->{$element}}) { |
| 2805 | | | | | (my $clean_attrib = $attrib) =~ s/^-//; |
| 2806 | | | | | $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" "; |
| 2807 | | | | | } |
| 2808 | | | | | $attribs =~ s/ $//; |
| 2809 | | | | | return $attribs; |
| 2810 | | | | | } |
| 2811 | | | | | END_OF_FUNC |
| 2812 | | | | | |
| 2813 | | | | | '_compile_all' => <<'END_OF_FUNC', |
| 2814 | | | | | sub _compile_all { |
| 2815 | | | | | for (@_) { |
| 2816 | | | | | next if defined(&$_); |
| 2817 | | | | | $AUTOLOAD = "CGI::$_"; |
| 2818 | | | | | _compile(); |
| 2819 | | | | | } |
| 2820 | | | | | } |
| 2821 | | | | | END_OF_FUNC |
| 2822 | | | | | |
| 2823 | | | | | ); |
| 2824 | | | | | |
| 2825 | | | | | ; |